Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/sd.mac
There are 2 other files named sd.mac in the archive. Click here to see a list.
SUBTTL SD module
;NAME: SD
;====
;AUTHOR: Kim Walden
;====== Claes Wihlborg
;VERSION: 3A [1,3,4,12,13,40,144,202]
;PURPOSE: To keep track of BLOCK LEVELS
;=======
;ENVIRONMENT: SD is called by: EXEC <entry point name>
;=========== and returns control by: RETURN
COMMENT;
Syntax Dispatch, SD, is part of PASS 1 and prepares
the setting up of a file DF1. SD will produce a list of records
(DCZQU, DCZHE and DCZHB) in which all declared entities will
have been properly rearranged, so that module DP may later scan
through the list once, linearly, and produce DF1.
The rearrangements are effected in one pass, simultaneously
with the syntax recognition. SR successively calls SD, when
encountering a declaration or the beginning
or end of a block, and SD keeps track of the nesting level
with the aid of a block stack (described below), consisting of 64 levels.
On each level, five sublists are maintained and are linked to the proper
sublist(s) of the nearest lower stack level when leaving a block,
until finally remains, when the outermost block is completed, a linear
list, properly ordered.
SD contains 12 ENTRY POINTS:
SDBEG, SDEND, SDZQU, SDSPEC, SDESPE, SDHID, SDABEG, SDALLOC, SDPEND, SDEXT, SDPPN
;
COMMENT;
Block Stack used by SD: (Contains 64 levels, each comprising 7 words)
offset
0 17 18 35
I--------------------------------I-------------------------------I
0 I start of list 1 I end of list 1 I
I--------------------------------I-------------------------------I
0 17 18 35
I--------------------------------I-------------------------------I
1 I start of list 2 I end of list 2 I
I--------------------------------I-------------------------------I
0 17 18 35
I--------------------------------I-------------------------------I
2 I start of list 3 I end of list 3 I
I--------------------------------I-------------------------------I
0 17 18 35
I--------------------------------I-------------------------------I
3 I start of list 4 I end of list 4 I
I--------------------------------I-------------------------------I
0 17 18 35
I--------------------------------I-------------------------------I
4 I start of list 5 I end of list 5 I
I--------------------------------I-------------------------------I
0 1 17 18 35
I--------------------------------I-------------------------------I
5 I ZHSOBL I ZHSLSB I
I-I------------------------------I-------------------------------I
6 I*I ZHSRBC I ZHSAST I
I-I------------------------------I-------------------------------I
* = ZHSRFL
ZHSOBL = own block length
ZHSLSB = length of largest subblock
ZHSRFL = reduced subblock flag
ZHSRBC = reduced subblock count
ZHSAST = start offset for this block
list 1: All DCZQU:s on this level, not in list 2 or list 3.
This list starts with a DCZHE or a DCZHB.
list 2: DCZQU:s of OBJECT REFERENCE variables and ARRAY variables
of this level.
list 3: DCZQU:s of SIMPLE TEXT variables of this level.
list 4: HIDDEN attributes (DCZQU:s) followed by
ATTRIBUTE sublists interior to this level.
list 5: PROTECTED attributes (DCZQU:s) followed by
BLOCK sublists interior to this level
;
COMMENT;
Assignments to certain fields, performed by SDBEG and SDEND on call:
(remarks on used notation is given below)
SDBEG
------------------------------------------------
ZHS
block type ZHE ZHE ZHE ZHB ZHB OBL ZHE ZHS ZHS ZHS
----- ---- SOL DLV EBL SBL KDP ZHE BNM RFL RBC AST
LEN
------------------------------------------------
QFOR (ZHE) +1 -1 0 0 off 0 0
ast
QRBLOCK (ZHE) +1 +0 +0 0 rbc+1 on rbc+1 +
obl
QUBLOCK (ZHE) +1 -1 +0 2 0 on 0 0
QPROCB (ZHB) +1 -1 DLV ebl 0 2/3/4 0 on 0 0
ast
QPROCB (ZHE) +0 +0 +0 0 0 on 0 +
obl
QPBLOCK (ZHB) +1 -1 DLV ebl 0 0 0 on 0 0
QCLASB (ZHB) +1 -1 DLV ebl & 0/2 0 off 0 0
QINSPEC (ZHB) +1 -1 +0 0 0 0 0 off 0 0
Remarks: Current level is the new level, just being constructed,
in case of SDBEG, and the level being current before
the stacklevel is decremented, in case of SDEND.
The fields of current level are furnished by the values
of the corresponding table entries, as a result of a call
to either SDBEG or SDEND. Entries preceded by + or - are
values relative to the contents of the same field of
nearest lower level.
Furthermore upper case letters in an entry means
the value of the corresponding field of CURRENT level, e.g. RBC,
and lower case letters denotes the value of the same field
of the nearest lower level, e.g. rbc.
SDEND
------------------
block type ZHE ZHE zhs zhs
LEN BNM rbc lsb
------------------
QFOR (ZHE) 0 0 - -
OBL
QRBLOCK (ZHE) + - RBC max(lsb,OBL+LSB)
LSB
OBL
QUBLOCK (ZHE) + 0 - -
LSB
OBL
QPROCB (ZHB) + 0 - -
LSB
OBL
QPROCB (ZHE) + 0 - OBL+LSB
LSB
OBL
QPBLOCK (ZHB) + 0 - -
LSB
QCLASB (ZHB) OBL 0 - -
QINSPEC (ZHB) 0 0 - -
;
SALL
SEARCH SIMMC1,SIMMAC,SIMMCR
CTITLE SD (SYNTAX DISPATCH)
MACINIT
TWOSEG
RELOC 400000
;FIELD DEFINITIONS:
;===== ===========
; DF (ZHSOBL,5,18,17) ;own block length
DF (ZHSLSB,5,18,35) ;largest subblock length
DF (ZHSRBC,6,17,17) ;reduced subblock count
; DF (ZHSAST,6,18,35) ;start offset for this block
; DSW (ZHSRFL,6,0) ;if on, subblocks are to be reduced
;MACRO DEFINITIONS:
;===== ===========
DEFINE ERROR(NR,TYP,MESSAGE)<
; IFN QDEBUG,<
; OUTSTR [ASCIZ/MESSAGE
;/]>
IFN QERIMP,<
ERR'TYP QE,Q1SD.E+NR
>
SETONA YERNC
>
DEFINE ERR1<
L YSMLIN
ST YELIN1
L YSMSEM
ST YESEM
CLEARM YELIN2>
DEFINE ERR2<
LF X0,ZQUTEM(XPTR)
ST YELIN1
ST YELIN2
CLEARM YESEM
LF X1,ZQULID(XPTR) >
DEFINE CHKSP(ATYP,ZTYP) ;used in sdspec
< LF X1,ZTYP(,ATYP)
IF JUMPE X1,FALSE
THEN LF ,ZTYP(XPTR)
JUMPN SDSPER
SF X1,ZTYP(XPTR)
FI >
DEFINE .EXIT(A)<L9()>
;ASSEMBLY TIME VARIABLES:
;======== ==== =========
QMXLEN=^D1023 ;max block length
QMXNRP=^D255 ;max number of param
QMXBNM=^D511 ;max reduced subbl count
QMXVRT=^D255 ;max number of virtuals
QEXMSK=7777 ;used to test for external id
QERRST=0 ;first error number
;LOCAL VARIABLES:
;===== =========
EXTERN YC1DC ;next free zde-record
EXTERN YSWCHA
EXTERN YSRIN,YSREN,YSRDEV,YSRPPN
EXTERN YLSVAL
EXTERN .JBREL ;top of low segment
EXTERN ZSE1
EXTERN YBSTP ;current stack level
EXTERN YASTR ;array start dczqu
EXTERN YDLV ;giving compilation level
EXTERN YSDENL ;linkage list used by sdend
EXTERN O1SFDC ;[144] Copies SFD record
EXTERN O1XR ;outp routine for cross ref
EXTERN T1AB ;termination error routine
EXTERN YDPD,YELIN1,YELIN2,YESEM,YMPSIZ,YSMLIN,YSMSEM
EXTERN YBHREL,I1RX50
EXTERN YRELBL ;[3] Set to [-1,,0] for global class/proc, zero for main
EXTERN YSIMNAME;[13] Name of global class/proc (RADIX50)
EXTERN YEXZQU ;[144] Start of chain of ZQU's for external specs
EXTERN YEXTS ;[144] File lookup info
EXTERN YZQUGLO ;[144] Copy of global ZQU for finding ATR file
EXTERN YSFD,YSFDP,YSFDN,YSFDPPN,YSFD1 ;[144] Temp SFD info
EXTERN SH ;[144] Symbol hash
;ENTRY POINTS:
;===== ======
INTERN SDBEG
INTERN SDEND
INTERN SDZQU
INTERN SDEXT
INTERN SDSPEC
INTERN SDESPE
INTERN SDHID ;[40]
INTERN SDABEG
INTERN SDAEND
INTERN SDPPN
INTERN SDALLOC
INTERN SDPEND
;REG ASSIGNMENTS FOR SD:
;=== =========== === ==
XSTACP=4 ;current stack level, never saved
;XALLOC=10 ;points to new record allocated by SDALLOC
SUBTTL submodule SDBEG
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: This routine is called by SR on each
entry to a BLOCK, a CLASS body or a PROCEDURE body.
It allocates a new DCZQU or DCZHB - record, and
sets the values of certain fields in this record,
according to TABLE above.
ERROR conditions: Block Stack overflow
calling ARGUMENTS: reg: contents of right half
18 20 21 23 24 35
I--------I--------I------------------I
X1SR1 I ZDETYP I ZHETYP I I
I--------I--------I------------------I
18 23 24 35
I-----------------I------------------I
X1SR2 I 0 I ZHEFIX I
I-----------------I------------------I
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;REG ASSIGNMENTS FOR SDBEG
;=== =========== === =====
XTAG=2 ;used to hold ZDETYP
XEBL=3 ;used to hold ZHEEBL
XTYP=5 ;used to hold ZHETYP
XSOL=7 ;used to hold ZHESOL
XDLV=11 ;used to hold ZHEDLV
XLEN=14 ;start offset of certain block types
PROC
SDBEG: IFONA YBSOV
RETURN
XALLO==XALLOC ;[202]
SAVE <XSOL,XDLV,XALLO,X1SR1,X1SR2> ;[202]
L XSTACP,YBSTP
MOVSS X1SR1
LF XTAG,ZDETYP(,X1SR1)
;allocate 3 word if ZHE, 4 words if ZHB
L [XWD 3,3]
CAIE XTAG,QQZHE
L [XWD 4,4]
EXEC SDALLO
;if stack full, then error
CAILE XSTACP,YDPD+77*QSTLL
GOTO SDERR0
;push stack, set pointers to start and end of list 1
;and clear remainder of stack level
ADDI XSTACP,QSTLL
ST XSTACP,YBSTP
SF XALLOC,ZHSSTR(XSTACP)
SF XALLOC,ZHSEND(XSTACP)
SETZB X0,X1
STD 1(XSTACP)
STD 3(XSTACP)
STD 5(XSTACP)
;set ZDETYP,ZHETYP and ZHEFIX
HLLM X1SR1,(XALLOC)
SF X1SR2,ZHEFIX(XALLOC)
LF XTYP,ZHETYP(,X1SR1)
XPRVZH=X1SR1
XPRVZQ=X1SR2
;only to be used when valid pointers
LF XPRVZH,ZHSSTR(XSTACP,-QSTLL)
LF XPRVZQ,ZHSEND(XSTACP,-QSTLL)
;if outermost block, get start values for DLV,EBL,SOL into regs
;if not, get values from lower level
IF CAIE XSTACP,YDPD+QSTLL
GOTO FALSE
THEN L XDLV,YDLV
MOVN XEBL,XDLV
SETZ XSOL,
IFON YSWCE
LI XEBL,0
ELSE
LF XSOL,ZHESOL(XPRVZH)
LF XDLV,ZHEDLV(XPRVZH)
HRRE XDLV,XDLV
LF XEBL,ZHEEBL(XPRVZH)
FI
SETZ XLEN,
CAIE XTAG,QQZHE
GOTO .ZHB
;ZHE found
.ZHE: SETON ZHSRFL(XSTACP)
CAIN XTYP,QPROCB
GOTO .AST
;RBLOCK or FOR
ADDI XSOL,1
CAIE XTYP,QFOR
GOTO .RED
;FOR-block
SETOFF ZHSRFL(XSTACP)
SUBI XDLV,1
GOTO .SOL
.RED: L X1,XSTACP
SUBI X1,QSTLL
IFOFF ZHSRFL(X1)
GOTO .URD
;to be reduced
LF ,ZHSRBC(XSTACP,-QSTLL)
ADDI 1
CAILE QMXBNM
EXEC SDERR8
SF ,ZHSRBC(XSTACP)
SF ,ZHEBNM(XALLOC)
.AST: LF ,ZHSAST(XSTACP,-QSTLL)
LF X1,ZHSOBL(XSTACP,-QSTLL)
ADD X1
SF ,ZHSAST(XSTACP)
GOTO .SOL
;to be unreduced
.URD: LI XTYP,QUBLOCK
SF XTYP,ZHETYP(XALLOC)
SUBI XDLV,1
LI XLEN,2
GOTO .OBL
;ZHB found
.ZHB: ADDI XSOL,1
SUBI XDLV,1
SETZM 3(XALLOC)
IF IFOFF YSWCE
GOTO FALSE
THEN SETON ZHBEXT(XALLOC)
FI
IF CAIGE XTYP,QCLASB
GOTO FALSE
THEN ;class/inspect
SETOFF ZHSRFL(XSTACP)
CAIE XTYP,QCLASB
GOTO .SOL
;class
LF ,ZQUQID(XPRVZQ)
SKIPN
LI XLEN,2
CAIN XSTACP,YDPD+QSTLL
GOTO .SBL
;not outermost level
LF ,ZHETYP(XPRVZH)
CAIE QCLASB
GOTO .SBL
SETON ZHBKDP(XPRVZH)
GOTO .SBL
FI
;proc(ZHB)/pblock
SETON ZHSRFL(XSTACP)
CAIE XTYP,QPROCB
GOTO .SBL
;proc(ZHB)
LI XLEN,2
LF ,ZQUTYP(XPRVZQ)
IF CAIN QNOTYPE
GOTO FALSE
THEN LI XLEN,3
CAIN QLREAL
LI XLEN,4
CAIN QTEXT
LI XLEN,4
FI
IF IFOFFA YSWEFO
GOTO FALSE
THEN SETF QEXFOR,ZHBMFO(XALLOC) ;[4]
LI XLEN,YFOPAD+1
ELSE
IF IFOFFA YSWEM
GOTO FALSE
THEN SETF QEXMAC,ZHBMFO(XALLOC) ;[4]
ELSE
IF IFOFFA YSWEMN
GOTO FALSE
THEN SETON ZHBNCK(XALLOC)
SETF QEXMAC,ZHBMFO(XALLOC) ;[13]
ELSE
IF IFOFFA YSWE40
GOTO FALSE
THEN SETF QEXF40,ZHBMFO(XALLOC) ;[4]
LI XLEN,YFOPAD+1
FI FI FI FI ;[4] Allow YSWEMQ together with YSWEMN
IF ;[4]
IFOFFA YSWEMQ ;[4]
GOTO FALSE ;[4]
THEN SETF QEXMQI,ZHBMFO(XALLOC) ;[4]
FI
.SBL: SF XEBL,ZHBSBL(XALLOC)
MOVN XEBL,XDLV
.OBL: SF XLEN,ZHSOBL(XSTACP)
SF XLEN,ZHELEN(XALLOC)
.SOL: SF XSOL,ZHESOL(XALLOC)
SF XDLV,ZHEDLV(XALLOC)
CAIL XEBL,QMAXDIS ;[12] Error if more than
EXEC SDER22 ;[12] 30 display levels
SF XEBL,ZHEEBL(XALLOC)
.EXIT():RETURN
SDERR0: ERR1
ERROR (0,,BLOCK STACK OVERFLOW)
SETONA YBSOV
SETONA YERNP2
GOTO .EXIT
EPROC
PURGE XEBL,XSOL,XDLV,XLEN,XTAG,XTYP,XPRVZH,XPRVZQ
SUBTTL submodule SDEND
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called by SR on EXIT from a BLOCK, a CLASS body or
a PROCEDURE body.
It links the lists of the current STACK level
together in a proper way, and ties them to the previous
level.
Furthermore it completes the fields of the records
corresponding to this level according to TABLE above.
ERROR conditions: Too large BLOCK LENGTH
Too many REDUCED SUBBLOCKS
calling ARGUMENTS: NONE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;REG ASSIGNMENT FOR SDEND
;=== ========== === =====
XTAG=2 ;used to hold ZDETYP
XZH=3 ;pointer to current ZHE/ZHB
XTYP=5 ;used to hold ZHETYP
XENP=7 ;stack entry of list to be extended
XSTP=10 ;stack entry of list to be appended
XEN=11 ;last record of list to be extended
XST=12 ;first record of list to be appended
XPTR=13 ;work pointer
PROC
SDEND: IFONA YBSOV
RETURN
SAVE <XTAG,XZH,XENP,XSTP,XEN,XST,XPTR>
L XSTACP,YBSTP
LF XZH,ZHSSTR(XSTACP) ;point to current ZHE/ZHB
LF XTAG,ZDETYP(XZH)
LF XTYP,ZHETYP(XZH)
IF ;Class then protect attributes [40]
CAIN XTAG,QQZHB
CAIE XTYP,QCLASB
GOTO FALSE
THEN
EXEC SDPRO ;Protect attributes
FI
;if proc(ZHB) or class(ZHB) prepare linkage to previous list 4
;else to prev list 5
LI 4-QSTLL
CAIE XTAG,QQZHB
GOTO .FIX
CAIE XTYP,QPROCB
CAIN XTYP,QCLASB
SUBI 1
.FIX: HRLM YSDENL+3
;go through YSDENL and for each entry,
;link together the two lists referred to
LI XPTR,YSDENL
WHILE LF XENP,ZHSSTR(XPTR)
ADD XENP,XSTACP
LF XSTP,ZHSEND(XPTR)
ADD XSTP,XSTACP
LF XST,ZHSSTR(XSTP)
LF XEN,ZHSEND(XENP)
JUMPE XST,TRUE ;jump if nothing to append
IF JUMPN XEN,FALSE
THEN ;nothing to extend
SF XST,ZHSSTR(XENP)
ELSE
SF XST,ZDELNK(XEN)
FI
LF XST,ZHSEND(XSTP)
SF XST,ZHSEND(XENP)
DO ADDI XPTR,1
SKIPE (XPTR)
OD
;calculate offset start
RNAME <XOFS,XRBC>,<XENP,XSTP>
CAIN XTYP,QINSPEC
GOTO .EXIT
CAIN XTYP,QFOR
GOTO .EXIT
LF XPTR,ZHSSTR(XSTACP)
LF XOFS,ZHSAST(XSTACP)
LF ,ZHELEN(XZH)
ADD XOFS,X0
;go through compound list and for each ZQU,
;calculate OFFSET and store in ZQUIND
WHILE LF XPTR,ZDELNK(XPTR)
JUMPE XPTR,FALSE
LF ,ZDETYP(XPTR)
CAIE QQZQU
GOTO FALSE
DO IF IFOFF ZQULEN(XPTR)
GOTO FALSE
THEN ;ZQUIND contains length
LF ,ZQUIND(XPTR)
SF XOFS,ZQUIND(XPTR)
ADD XOFS,X0 ;incr OFFSET counter
SETOFF ZQULEN(XPTR)
FI
OD
;form ZHSOBL+ZHSLSB
LF ,ZHSOBL(XSTACP)
LF X1,ZHSLSB(XSTACP)
ADD X1
;set length
CAILE QMXLEN
EXEC SDERR7
SF ,ZHELEN(XZH)
;if proc(ZHE) then update ZHSLSB
IF CAIN XTYP,QPROCB
CAIE XTAG,QQZHE
GOTO FALSE
THEN SF ,ZHSLSB(XSTACP,-QSTLL)
FI
CAIE XTYP,QRBLOCK
GOTO .EXIT
;reduced block
LF X1,ZHSLSB(XSTACP,-QSTLL)
IF CAMG X1
GOTO FALSE
THEN ;OBL+LSB>previous LSB
SF ,ZHSLSB(XSTACP,-QSTLL)
FI
LF XRBC,ZHSRBC(XSTACP)
SF XRBC,ZHSRBC(XSTACP,-QSTLL)
.EXIT():SUBI XSTACP,QSTLL ;pop block stack
ST XSTACP,YBSTP
RETURN
EPROC
PURGE XZH,XST,XEN,XOFS,XRBC,XTAG,XTYP
;YSDENL: XWD 0,1
; XWD 0,2
; XWD 0,3
; XWD 4-QSTLL/3-QSTLL,0
; XWD 4-QSTLL,4
; XWD 0,0
SDERR7: PROC
ERR1
ERROR(7,,TOO LARGE BLOCK LENGTH)
RETURN
EPROC
SDERR8: PROC
ERR1
ERROR(8,,TOO MANY REDUCED SUBBLOCKS)
RETURN
EPROC
SUBTTL submodule SDZQU
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Sets up a new DCZQU record, links it properly into
the DC list (of current level), and sets values to
fields in the record, according to input arguments.
ERROR conditions: NONE
calling ARGUMENTS: ac: contents of right half
18 23 24 35
I-------------I----------------------I
X1CUR I 0 I ZQULID I
I-------------I----------------------I
18 20 26 29 30 32 33 35
I--------I------I--------I-----I-----I
X1SR1 I ZDETYP I 0 I ZQUTYP I MOD I KND I
I--------I------I--------I-----I-----I
18 35
I------------------------------------I
X1SR2 I ZQUIND I
I------------------------------------I
18 35
I------------------------------------I
X1SR3 I ZQUQID I
I------------------------------------I
18 35
I------------------------------------I
mem loc: YLSCLIN I ZQULNE I
I------------------------------------I
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;AC ASSIGNMENTS FOR SDZQU:
;== =========== === =====
XKND=2 ;used to hold ZQUKND
XLEN=3 ;length of decl var
XTYP=5 ;used to hold ZQUTYP
XPTR=7 ;work pointer
PROC
SDZQU: IFONA YBSOV
RETURN
IF IFONA YSWC
CAIGE X1CUR,QLOWID
GOTO FALSE
THEN ;output symbol to cross ref table
TRO X1CUR,1B18
EXEC O1XR
TRZ X1CUR,1B18
FI
XALLO==XALLOC ;[202]
SAVE <XKND,XLEN,XPTR,XALLO> ;[202]
L XSTACP,YBSTP
L [XWD 3,3]
EXEC SDALLOC ;allocate 3 zero words
HRLM X1SR1,(XALLOC) ;set ZDETYP,ZQUTYP,ZQUMOD,ZQUKND
LF ,YLSCLIN
;set fields
SF ,ZQUTEM(XALLOC)
SF X1CUR,ZQULID(XALLOC)
SF X1SR3,ZQUQID(XALLOC)
LF XTYP,ZQUTYP(XALLOC)
SETZ XPTR,
IF
JUMPE XTYP,FALSE ;jump if QUNDEF
LF ,ZQUMOD(XALLOC)
CAIN QVIRTUAL
GOTO FALSE
THEN ;not VIRTUAL or FORMAL
LF XKND,ZQUKND(XALLOC)
IF
CAIE XTYP,QLABEL
CAIN XKND,QPROCE
GOTO TRUE
CAIE XKND,QCLASS
GOTO FALSE
THEN ;label,procedure or class
SF X1SR2,ZQUIND(XALLOC)
IF ;This represents the outermost block
CAIN XSTACP,YDPD ;(bottom of block stack)
CAIN XTYP,QLABEL
GOTO FALSE
THEN ;[1] replace the name .MAIN in the REL file
SETON ZQUGLO(XALLOC)
L YZSE1(X1CUR)
EXEC I1RX50
ST YSIMNAME ;[13] Record the name
HRRZ X1,YBHREL
ST 7(X1) ;[1] Change name (in name block)
ST 4(X1) ;[1] Also in entry block
HRROS YRELBL ;[3] Signal external class/proc
;[144] Copy ZQU for inclusion in YEXZQU list
; Also make a ZHB
STACK X1NXT
LD (XALLOC)
ZF ZQUIND
STD YZQUGLO
;Dummy ZHB
SETZB X1ID2,X1NXT
L X1ID1,YEXTS+11 ;[144] REL file device
IF ;Device given
JUMPE X1ID1,FALSE
THEN ;Find its internal id number
SETOFA YZSE ;New entries allowed
EXEC SH
FI
SF X1NXT,ZHBDEV(,YZQUGLO+3)
L X1ID1,YEXTS+4 ;REL file name
EXEC SH
SF X1NXT,ZHBXID(,YZQUGLO+3)
L X1,YEXTS+7 ;PPN
IF ;PPN = 0
JUMPN X1,FALSE
THEN ;Explicit request if filename differs
; from SIMULA name
L YEXTS+4 ;File name
CAME YZSE1(X1CUR)
SETO X1, ;Signal with ppn=-1
FI
SF X1,ZHBPPN(,YZQUGLO+3)
LI YZQUGLO
EXEC SDZQUC ;Put the copy on a chain
UNSTK X1NXT
FI
ELSE
LI XLEN,1
LI XPTR,1
IF
CAIE XTYP,QREF
CAIN XKND,QARRAY
AOJA XPTR,FALSE
THEN
CAIN XTYP,QLREAL
SOSA XPTR
CAIN XTYP,QTEXT
AOSA XLEN
SUBI XPTR,1
FI
SF XLEN,ZQUIND(XALLOC)
SETON ZQULEN(XALLOC)
LF ,ZHSOBL(XSTACP)
ADD XLEN
SF ,ZHSOBL(XSTACP)
FI
FI
RNAME <XPRV>,<XKND>
;establish link to prev record
ADD XPTR,XSTACP
IF
SKIPE (XPTR) ;skip if list empty
GOTO FALSE
THEN
SF XALLOC,ZHSSTR(XPTR)
ELSE
LF XPRV,ZHSEND(XPTR) ;point to last rec
SF XALLOC,ZDELNK(XPRV)
FI
SF XALLOC,ZHSEND(XPTR)
RETURN
EPROC
PURGE XLEN,XTYP,XPTR
SUBTTL submodule SDEXT
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: SDEXT is called for every external item in the
source text. It creates one ZQU, one ZHB and
one ZHE(QQUACH) record. However not all information
is available but is inserted by DP when reading the
corresponding ATR-file.
Entry conditions:
18 20 21 23 24 35
I--------I--------I------------------I
X1SR1 I ZDETYP I ZHETYP I I
I--------I--------I------------------I
18 20 26 29 30 32 33 35
I--------I------I--------I-----I-----I
X1SR2 I ZDETYP I 0 I ZQUTYP I MOD I KND I
I--------I------I--------I-----I-----I
18 35
I------------------------------------I
X1SR3 I ZQUQID I
I------------------------------------I
YSRIN Internal id-no
YSREN External id-no (name of ATR-file)
YSRDEV Device of ATR-file
YSRPPN PPN of ATR-file
YLSLLIN Line no of declaration
ERRORS:
External must be copied into main
External must not be copied indirectly
External must not be attribute
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
XPTR==2
XDLV==3
XSOL==4
PROC
SDEXT:
IFONA YBSOV
RETURN
XALLO==XALLOC ;[202]
SAVE <XALLO,X1CUR,XPTR,XDLV,XSOL> ;[202]
L [13,,13]
EXEC SDALLOC
SKIPN X1CUR,YSRIN
L X1CUR,YSREN
TRO X1CUR,3B19
IFONA YSWC
EXEC O1XR
TRZ X1CUR,3B19
;create ZQU
SF X1CUR,ZQULID(XALLOC)
HRLM X1SR1,(XALLOC)
SETON ZQUEXT(XALLOC)
LF ,YLSLLIN
SF ,ZQUTEM(XALLOC)
SF X1SR3,ZQUQID(XALLOC)
L XPTR,YBSTP
;link ZQU
IF
SKIPE (XPTR)
GOTO FALSE
THEN
SF XALLOC,ZHSSTR(XPTR)
ELSE
LF X1,ZHSEND(XPTR)
SF XALLOC,ZDELNK(X1)
FI
SF XALLOC,ZHSEND(XPTR)
LI (XALLOC) ;[144]
EXEC SDZQUC ;[144] Put on YEXZQU chain
;create ZHB
ADDI XALLOC,3
HRLM X1SR2,(XALLOC)
IF ;we are now at block stack bottom
CAIE XPTR,YDPD
GOTO FALSE
THEN ;we have an external declaration outside the program
LI XDLV,0
LI XSOL,1
IF
IFON YSWCE
GOTO FALSE
THEN ;outside MAIN
EXEC XER1
FI
ELSE ;EXTERNAL is copied
LF X1,ZHSSTR(XPTR)
LF XDLV,ZHEEBL(X1)
SF XDLV,ZHBSBL(XALLOC)
LF XDLV,ZHEDLV(X1)
SUBI XDLV,1
LF XSOL,ZHESOL(X1)
ADDI XSOL,1
IF
IFOFF YSWCE
GOTO FALSE
THEN ;indirect copying
EXEC XER2
FI
IF
LF ,ZHETYP(X1)
CAIE QCLASB
GOTO FALSE
THEN ;EXTERNAL as attribute
EXEC XER3
FI
FI
SF XDLV,ZHEDLV(XALLOC)
MOVN XDLV,XDLV
CAIL XDLV,QMAXDIS ;[12] TEST ON MAX DISPLAY LEVEL
EXEC SDER22 ;[12]
SF XDLV,ZHEEBL(XALLOC)
SF XSOL,ZHESOL(XALLOC)
L YSRDEV
SF ,ZHBDEV(XALLOC)
L YSREN
SF ,ZHBXID(XALLOC)
SKIPE X1,YSFDN ;[144] If SFD's were present in file spec
EXEC SDMSFD ;[144] Make new SFD record
L YSRPPN
SF ,ZHBPPN(XALLOC)
;link ZHB
IF
SKIPE 3(XPTR)
GOTO FALSE
THEN ;ATR list empty
SF XALLOC,ZHSSTR(XPTR,3)
ELSE
LF X1,ZHSEND(XPTR,3)
SF XALLOC,ZDELNK(X1)
FI
SF XALLOC,ZHSEND(XPTR,3)
;create ZHE(QQUACH)
ADDI XALLOC,5
ADDI X1CUR,(BYTE (3)QQZHE,QQUACH(30)0)
MOVSM X1CUR,(XALLOC)
SETOM 1(XALLOC)
;link ZHE
IF
SKIPE 4(XPTR)
GOTO FALSE
THEN ;subblock list empty
SF XALLOC,ZHSEND(XPTR,4)
SETZM 2(XALLOC)
ELSE
LF X1,ZHSSTR(XPTR,4)
SF X1,ZDELNK(XALLOC)
FI
SF XALLOC,ZHSSTR(XPTR,4)
RETURN
EPROC
XER1: PROC
ERR1
ERROR(11,,EXTERNAL MUST BE COPIED INTO MAIN)
RETURN
EPROC
XER2: PROC
ERR1
ERROR(12,,EXTERNAL MUST NOT BE INDIRECTLY COPIED)
RETURN
EPROC
XER3: PROC
ERR1
ERROR(13,,EXTERNAL MUST NOT BE ATTRIBUTE)
RETURN
EPROC
;[12] NEW ERROR MESS.
SDER22: PROC
ERR1
ERROR(22,,DISPLAY SIZE OVERFLOW)
RETURN
EPROC
SDZQUC: PROC ;[144] (New) Put ZQU on chain of externals
;Input: X0 :- ZQU record
MOVS X1,YEXZQU ; X1:=[first ZQU on chain,,last]
IF ; List is still empty
JUMPN X1,FALSE
THEN ;Start with this ZQU
ST YEXZQU
ELSE ;Chain it
SF ,ZQUIND(X1)
FI ;
HRLM YEXZQU ; Remember this as last ZQU
RETURN
EPROC
SDMSFD::PROC ;[144] Make SFD path from YSFD table
SAVE X2
LI X1,YSRPPN
SETZ X2, ;Make the copy, allocating a new record and updating
EXEC O1SFDC ;YSRPPN to point to the new copy
RETURN
EPROC
SUBTTL submodule SDSPEC
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called by SR when encountering a parameter specification.
It sets the corresponding field in the DCZQU record.
ERROR conditions: specified but not FORMAL
parameter previously specified
calling ARGUMENTS: reg: contents of right half
18 26 29 30 32 33 35
I---------------I--------I-----I-----I
X1SR1 I 0 I ZQUTYP I MOD I KND I
I---------------I--------I-----I-----I
18 23 24 35
I-------------I----------------------I
X1CUR I 0 I ZQULID I
I-------------I----------------------I
18 35
I------------------------------------I
X1SR3 I ZQUQID I
I------------------------------------I
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;REG ASSIGNMENTS FOR SDSPEC:
;=== =========== === ======
XPTR=5 ;work pointer
PROC
SDSPEC: IFONA YBSOV
RETURN
SAVE <X1SR1,XPTR>
L XSTACP,YBSTP
LF XPTR,ZHSSTR(XSTACP) ;point to DCZHB
XSPEC=X1SR1
MOVSS XSPEC
WHILE LF XPTR,ZDELNK(XPTR) ;point to next record
JUMPE XPTR,SDERR2
DO LF ,ZQULID(XPTR)
CAME X1CUR
OD
;match found
CHKSP (XSPEC,ZQUTYP)
CAIN X1,QREF
SF X1SR3,ZQUQID(XPTR)
CHKSP (XSPEC,ZQUMOD)
CHKSP (XSPEC,ZQUKND)
RETURN
SDERR2:
L X1,X1CUR
ERR1
ERROR(2,I1,XXXX SPECIFIED BUT NOT FORMAL)
RETURN
SDSPER:
EXEC SDERR1
RETURN
EPROC
SDERR1: PROC
SAVE X1
L X1,X1CUR
ERR1
ERROR(1,I1,XXXX PREVIOUSLY SPECIFIED)
RETURN
EPROC
PURGE XPTR,XSPEC
SUBTTL submodule SDESPE
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called by SR when the last parameter specification
has been processed.
It scans through all DCZQU:s of current level and
checks validity of MODE/TYPE/SPEC combinations.
An action table is used to speed up checking and
default value settings.
Virtual indices and parameter lengths are also
calculated.
ERROR conditions: parameter not specified
parameter illegally specified
too many formals
too many virtuals
illegal FORTRAN specification
calling ARGUMENTS: NONE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;REG ASSIGNMENTS FOR SDESPE:
;=== =========== === ======
XZPTR=1 ;pointer to DCZHB
XMOD=2 ;used to hold ZQUMOD
XKND=3 ;used to hold ZQUKND
XTYP=5 ;used to hold ZQUTYP
XPTR=7 ;work pointer
XLEN=10 ;used to accumulate block length
XIDX=11 ;virt index count
XNRP=12 ;number of param
XSPEC=13 ;used to index action table
XSTAT=14 ;-1 if global fortran procedure
PROC
SDESPE: IFONA YBSOV
RETURN
SAVE <XMOD,XKND,XPTR,XLEN,XIDX,XNRP,XSPEC>
L XSTACP,YBSTP
LF XZPTR,ZHSSTR(XSTACP) ;point to DCZHB
MOVE XPTR,XZPTR
SETZB XIDX,XNRP
LF XLEN,ZHSOBL(XSTACP)
SETZ XSTAT,
IFOFFA YSWE40
IFONA YSWEFO
SETO XSTAT,
.NSP: WHILE LF XPTR,ZDELNK(XPTR) ;link to next record
JUMPE XPTR,FALSE
DO LF XTYP,ZQUTYP(XPTR)
JUMPE XTYP,SDERR3
LF XMOD,ZQUMOD(XPTR)
IF
CAIE XMOD,QVIRTUAL
GOTO FALSE
THEN
SF XIDX,ZQUIND(XPTR) ;index to ZQUIND
AOJA XIDX,.NSP
FI
ADDI XNRP,1
;calculate ACTION TABLE entry
IMULI XMOD,3
LF XKND,ZQUKND(XPTR)
ADD XMOD,XKND
SUBI XMOD,1
SUBI XTYP,1
;get table info and take appropriate action
LDB XSPEC,YSDPTB(XTYP)
TRNN XSPEC,3b33
EXEC SDERR4
IF JUMPE XSTAT,FALSE
THEN ;external FORTRAN procedure
TRNN XSPEC,1b34
GOTO XER4
FI
IF
TRNE XSPEC,2B33 ;skip if dflt ref
GOTO FALSE
THEN
LI QREFER
SF ,ZQUMOD(XPTR)
ELSE
IF
TRNE XSPEC,1B33 ;dflt val
GOTO FALSE
THEN
LI QVALUE
SF ,ZQUMOD(XPTR)
FI
FI
TRZ XSPEC,7b34 ;isolate LEN field
ADDI XSPEC,1
SF (XSPEC) ZQUIND(XPTR) ;set length
SETON ZQULEN(XPTR) ;seton offset marker
ADD XLEN,XSPEC ;update len acc
OD
CAILE XNRP,QMXNRP
EXEC SDERR5
SF XNRP,ZHBNRP(XZPTR)
CAILE XIDX,QMXVRT
EXEC SDERR6
SF XIDX,ZHBVRT(XZPTR)
SF XLEN,ZHSOBL(XSTACP)
RETURN
SDERR3: LI QREFER
SF ,ZQUMOD(XPTR) ;set MODE reference, not to fool PHASE2
;into believing that parameter list is terminated
STACK X1
ADDI XNRP,1
ERR2
ERROR(3,I1,FORMAL PARAMETER XXXX NOT SPECIFIED)
UNSTK X1
GOTO .NSP
EPROC
SDERR4: PROC
SAVE X1
ERR2
ERROR(4,I1,FORMAL PARAMETER XXXX ILLEGALLY SPECIFIED)
RETURN
EPROC
SDERR5: PROC
LI XPTR,-3(XZPTR)
ERR2
ERROR(5,I1,XXXX HAS TOO MANY FORMALS)
LI XZPTR,3(XPTR)
RETURN
EPROC
SDERR6: PROC
LI XPTR,-3(XZPTR)
ERR2
ERROR(6,I1,XXXX HAS TOO MANY VIRTUALS)
LI XZPTR,3(XPTR)
RETURN
EPROC
XER4: PROC
STACK X1
ERR2
ERROR(14,I1,XXXX HAS ILLEGAL FORTRAN SPECIFICATION)
SETONA YERNP2
UNSTK X1
GOTO .NSP
EPROC
SCALAR(<QI,QR,QV,QS>)
SCALAR(<L1,L2,F1,F2>)
;Action Table:
YSDTAB:
; simple
; (UNSPECIFIED: array )
; procedure
; integer real longreal char boolean text ref label notype
BYTE(2) QV,F1, QV,F1, QV,F2, QV,F1, QV,F1, QR,L2, QR,L1, QR,L2, 0,0
BYTE(2) QR,F1, QR,F1, QR,F1, QR,F1, QR,F1, QR,L1, QR,L1, 0,0, 0,0
BYTE(2) QR,L2, QR,L2, QR,L2, QR,L2, QR,L2, QR,L2, QR,L2, QR,L2, QR,L2
; simple
; (VALUE: array )
; procedure
; integer real longreal char boolean text ref label notype
BYTE(2) QS,F1, QS,F1, QS,F2, QS,F1, QS,F1, QS,L2, QI,L1, QI,L2, 0,0
BYTE(2) QS,F1, QS,F1, QS,F1, QS,F1, QS,F1, QI,L1, QI,L1, 0,0, 0,0
BYTE(2) QI,L2, QI,L2, QI,L2, QI,L2, QI,L2, QI,L2, QI,L2, QI,L2, QI,L2
; simple
; (NAME: array )
; procedure
; integer real longreal char boolean text ref label notype
BYTE(2) QS,F2, QS,F2, QS,F2, QS,F2, QS,F2, QS,L2, QS,L2, QS,L2, 0,0
BYTE(2) QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, 0,0, 0,0
BYTE(2) QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2, QS,L2
COMMENT;
meaning of ENTRY: bits <0:1> 00: illegal combination (QI)
01: default mode = REF to be set (QR)
10: default mode = VALUE to be set (QV)
11: legal combination (QS)
<2> 0: parameter not to be used
in FORTRAN sub programs
1: parameter can be used
in FORTRAN sub programs
<3> 0: length of parameter = 1
1: length of parameter = 2
;
QBPPOS=3
;Pointer Table to Action Table:
YSDPTB: REPEAT 11,<POINT 4,YSDTAB(XMOD),QBPPOS
QBPPOS=QBPPOS+4>
PURGE XTYP,XZPTR,XMOD,XKND,XPTR,XLEN,XIDX,XNRP,XSPEC
SUBTTL submodule SDHID [40]
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called from SR for each identifier in the
protection part.
Arguments: X1SR1 contains flags in left halfword and fields in right.
ERROR conditions: Conflict between specifications.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SDHID: PROC
IFONA YBSOV
RETURN
IFONA YSWC
EXEC O1XR
XALLO==XALLOC ;[202]
SAVE <XALLO,X2,X3> ;[202]
L X2,YBSTP
ADDI X2,4
MOVS X1,X1SR1
ADD X1,X1SR1
;TEST IF PROTECTED
IFONA ZQUTPT(X1)
EXEC SDHIDS
;TEST IF HIDDEN
SUBI X2,1
IFONA ZQUHID(X1)
EXEC SDHIDS
RETURN
EPROC
SDHIDS: PROC
LF X3,ZHSSTR(X2)
IF
JUMPE X3,FALSE
WHENNOT X3,ZQU
GOTO FALSE
THEN ;CHECK FOR CONFLICT WITH EARLIER SPECS
IF
L X1
XOR (X3)
IFOFFA ZQUNOT
GOTO FALSE
THEN ;CONFLICT
TRON X1SR1,1
EXEC SDER17
RETURN
FI
L XALLOC,X3
LOOP
LF ,ZQULID(XALLOC)
IF
CAME X1CUR
GOTO FALSE
THEN
TRON X1,2
EXEC SDERR1
RETURN
FI
AS
LF XALLOC,ZDELNK(XALLOC)
JUMPE XALLOC,FALSE
WHEN XALLOC,ZQU
GOTO TRUE
SA
FI
L [3,,3]
EXEC SDALLOC
SETZM 1(XALLOC)
SF X3,ZDELNK(XALLOC)
SF XALLOC,ZHSSTR(X2)
SKIPN X3
SF XALLOC,ZHSEND(X2)
SETOFA ZQUTPT(X1)
ST X1,(XALLOC)
LF ,YLSCLIN
SF ,ZQUTEM(XALLOC)
SETON ZQUIVA(XALLOC)
SF X1CUR,ZQULID(XALLOC)
RETURN
EPROC
SDER17: PROC
ERR1
ERROR(17,,conflict between specifications)
RETURN
EPROC
SUBTTL submodule SDPRO [40]
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called from SDEND when end of class body is recognized.
Searches attributes for protection.
ERROR conditions: PROTECTED attribute not found.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
XPTR=3
DEFINE FIND1<
EXEC SDPRO1
>
DEFINE FIND2(N)<
LF X1,ZHSSTR(XSTACP,N-1)
IFE N-1,<LF X1,ZDELNK(X1)>
WHILE
JUMPE X1,FALSE
DO
SETON ZQUTPT(X1)
SETON ZQUIVA(X1)
LF X1,ZDELNK(X1)
OD
>
DEFINE FIND3(N)<
LF X1,ZHSSTR(XSTACP,N-1)
IFE N-1,<LF X1,ZDELNK(X1)>
WHILE
JUMPE X1,FALSE
DO
LF ,ZQULID(X1)
CAMN X2
RETURN
LF X1,ZDELNK(X1)
OD
>
SDPRO: PROC
SAVE <X1,X2,XPTR>
LF XPTR,ZHSSTR(XSTACP,4)
IF
JUMPE XPTR,FALSE
WHENNOT XPTR,ZQU
GOTO FALSE
THEN ;PROTECT SPECIFICATIONS EXISTS
IF
IFON ZQUNOT(XPTR)
GOTO FALSE
THEN ;PROTECT NAMED ATTRIBUTES
LOOP
FIND1
SETON ZQUIVA(X1)
SETON ZQUTPT(X1)
AS
LF XPTR,ZDELNK(XPTR)
JUMPE XPTR,FALSE
WHEN XPTR,ZQU
GOTO TRUE
SA
ELSE ;PROTECT ALL BUT NAMED ATTRIBUTES
FIND2(1)
FIND2(2)
FIND2(3)
LOOP
FIND1
SETOFF ZQUIVA(X1)
SETOFF ZQUTPT(X1)
AS
LF XPTR,ZDELNK(XPTR)
JUMPE XPTR,FALSE
WHEN XPTR,ZQU
GOTO TRUE
SA
FI
SF XPTR,ZHSSTR(XSTACP,4)
IF
JUMPN XPTR,FALSE
THEN
SF XPTR,ZHSEND(XSTACP,4)
FI
FI
RETURN
EPROC
SDPRO1: PROC
LF X2,ZQULID(XPTR)
FIND3(1)
FIND3(2)
FIND3(3)
SDER23:
ERR2
ERROR(23,I1,attribute XXXX not found)
L X1,XPTR
RETURN
EPROC
SUBTTL submodule SDABEG
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Called by SR after having issued a first call
on SDZQU when processing an ARRAY declaration.
It saves the last DCZQU address.
ERROR conditions: NONE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
PROC
SDABEG: IFONA YBSOV
RETURN
L X1,YBSTP
LF ,ZHSEND(X1,2) ;point to end of ARRAY/REF list
ST YASTR ;save adr of DCZQU of last ARRAY var
RETURN
EPROC
SUBTTL submodule SDPEND
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: To fixup the fields of the OUTERMOST
stack level upon PROGRAM EXIT.
ERROR conditions: NONE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SDPEND: LF ,ZHSOBL(,YDPD)
ST YMPSIZ
LF ,ZHSLSB(,YDPD)
ADDM YMPSIZ
RETURN
SUBTTL submodule SDAEND
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: To furnish all the ARRAYs of an ARRAY segment
with their proper BOUNDS.
ERROR conditions: NONE
calling ARGUMENTS: reg: contents of right half
18 30 35
I------------------------I-----------I
X1SR2 I 0 I ZQUNSB I
I------------------------I-----------I
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
PROC
SDAEND: IFONA YBSOV
RETURN
L X1,YASTR
LOOP SF X1SR2,ZQUNSB(X1) ;store NSB arg
LF X1,ZDELNK(X1) ;link to next record
AS JUMPG X1,TRUE
SA
RETURN
EPROC
SUBTTL submodule SDPPN
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: When a PPN is found in an external identifier,
the lexical scanner converts the numbers as if
they were decimal and stores them in YLSVAL.
The function of SDPPN is to reconvert them from
decimal to octal.
Entry conditions:
YLSVAL holds value to be converted
Exit conditions:
X0 right halfword holds the converted value
ERRORS: NOT OCTAL DIGIT IN PPN
MORE THAN SIX DIGITS IN PPN
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SDPPN: PROC
SAVE <X1,X2,X3>
L YLSVAL
LI X3,6
LOOP
IDIVI ^D10
CAILE X1,7
GOTO XER5
LSHC X1,-3
AS
SOJG X3,TRUE
SA
JUMPN XER6
HLRZ X2
RETURN
XER5:
ERR1
ERROR(15,,PPN NOT OCTAL DIGIT)
RETURN
XER6:
ERR1
ERROR(16,,PPN MORE THAN SIX DIGITS)
RETURN
EPROC
SUBTTL SUBROUTINE SDALLOC
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function: Allocates memory in the dynamic pool.
Entry conditions: X0 = N,,N N= number of words to allocate
Exit conditions: XALLOC points to base of allocated area
ERRORS: NOT ENOUGH CORE PASS 1
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
SDALLOC:PROC
HRRZ XALLOC,YC1DC
ADDM YC1DC
SKIPGE YC1DC
GOTO ZSET
HRRZ .JBREL
ADDI 4000
IF
IFG QTRACE,<EXTERN YTRPAS
IFON YTRSW
GOTO FALSE>
CORE
GOTO FALSE
THEN
MOVSI -4000
ADDM YC1DC
ELSE
ERR QT,Q1SD.T
BRANCH T1AB
FI
ZSET: SETZM 2(XALLOC)
RETURN
EPROC
LIT
END