Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/13/ca.mac
There are 2 other files named ca.mac in the archive. Click here to see a list.
SUBTTL LARS ENDERIN JUNE 1973
COMMENT; ==== MODULE CA ====
AUTHOR: LARS ENDERIN
VERSION: 3A [6,13,17,30,40,41,132,136,140,144,176]
PURPOSE: HANDLES CONTROL SYMBOLS (I E NEITHER OPERATORS NOR
OPERANDS)
CONTENTS: ACTIONS FOR BBLK,BPROG, ETC. (SYMBOL TYPE SYMBT2)
ENTRY: CAEN
;
TWOSEG
RELOC 400K
SEARCH SIMMAC,SIMMC2,SIMMCR,SIMRPA
CTITLE CA
SALL
MACINIT
;--- EXTERNAL ROUTINES
IFN QDEBUG,<EXTERN YCADB,O2DB1,O2DB2,O2DB3
>
EXTERN CGAD,CGCA,CGCC,CGCO,CGIM,CGIM1,CGMO,CGMO1,CGVA,O2AF,O2SM
EXTERN O2AB,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4
EXTERN CARL,CGPU
EXTERN O2EX,M2CO
EXTERN O2LN1,O2LN2,O2LN3,O2LN4,O2LN5,O2LN6
EXTERN O2AD,O2CF,O2DF,O2DFTE,O2GA,O2GF,O2GI,O2GR,O2GW,O2GWD,O2IV
EXTERN CGLO,CGLO1,CGRD
;--- EXTERNAL DATA
EXTERN QOPSTZ
EXTERN YUNDEC,YRELLT,YRELST,YORFX,YQRELR,YQRELL,YQRELT,YCANTR,YCGSWC,YQREL,YCASM
EXTERN YDCSTB,YTEXTI,YPROCI,YSIMUI,YSYSI,YSYSO,YSWCHA
EXTERN YCALID,YCAMTC,YCAQND,YCAZMP,YCAZHE,YLXIAC
EXTERN YELIN1,YELIN2 ;[40]
EXTERN YBKST,YBKSTP,YCERFL,YDCSTO,YDCSTP,YDICTB,YEXPL,YEXPP
EXTERN YFORSI,YGAP,YLINE,YMPSIZ,YCABKB
EXTERN YOPSTB,YOPST,YOPSTP,YORZHB,YORZQU,YO2ZSD
EXTERN YRDSTO,YRDSTP,YRELPT,YSTATM,YTENT,YZHET,YZHBXC
EXTERN YRELCD,YSWRF
INTERN CACO,CADS,CADISP,CAEN,CADS,CAUD,CAUNDI,CAUS,CAUSTD,ERROR.
INTERN CAPROT,CAUNPR ;[40]
SUBTTL MACROS, OPDEFS
;--- MACRO DEFINITIONS
CGINIT
DEFINE $$$DO <GOTO FALSE>
DEFINE $$$THEN <GOTO FALSE>
IFE QDEBUG,<DEFINE CHKOFS(F)<>
>
IFN QDEBUG,<
DEFINE CHKOFS(F)<
IRP F,<
IFN <<WOFS>&777777-OFFSET(F)>,<
CFAIL WRONG OFFSET: F
>>>
OPDEF RH [POINT 18,0,35]
RH==RH
DEFINE RIGHTHALF(A)<
IFN <RH-<<$'A>&<777777B17>>>,
<CFAIL A IS NOT IN RH>>
>
DEFINE NEXTWORD<WOFS==WOFS+1>
;--- OPDEF'S
OPDEF NEXT [POPJ XPDP,]
OPDEF UNDISP [PUSHJ XPDP,CAUD]
SUBTTL TEMPORARY DEFINITIONS
DEFINE D(X) <
X=..N
..N=..N+1
>
;MISCELLANEOUS:
..N=100
D EILSYM
D EDCOFL
SUBTTL CAEB
COMMENT; === ROUTINE CAEB ===
PURPOSE: CALLED AT END OF UNREDUCED SUBBLOCK, CLASS,
PROCEDURE OR PREFIXED BLOCK.
OUTPUTS PROTOTYPE AND VARIABLE MAP (FOR GARBAGE COLLECTOR
AND ENTRY INTO REDUCED SUBBLOCK) FOR THE BLOCK AND ANY
ENCLOSED, REDUCED SUBBLOCKS. UNDISPLAYS THE ZQU RECORDS.
REMOVES THE BLOCK FROM DSTACK EXCEPT WHEN IT IS A CLASS BLOCK.
OUTPUTS LINE AND SYMBOL TABLE ENTRIES FOR BLOCK
ENTRY: EXEC CAEB
EXIT: RETURN
USES: CADS,CAMM,CAUNDI,CAUD,O2GA,O2GF,O2GP,O2GR,O2LN4,CAUS,CAFQX2
INPUT: XZHE POINTS TO ZHE OR ZHB FOR TERMINATING BLOCK
;
XFIX=X5
CAEB: PROC
SAVE <X2,X3,X4,X5,X6,XP1>
EXEC O2LN4
L YRELST
ST YCASM ; SYMBOL TABLE START
; RESET YZHBXCB
IF CAME XZHE,YZHBXC
THEN
HRRZ X1,YBKSTP
LOOP SOS X1
AS
HRRZ X2,(X1)
CAIG X1,YBKST
GOTO FALSE
WHENNOT X2,ZHB
GOTO TRUE
IFEQF X2,ZHETYP,QINSPE
GOTO TRUE
SA
ST X2,YZHBXC
FI
ST XZHE,YCAZHE
SETZM XP1
IF
LF() ZHETYP(XZHE)
CAIE QPROCB
THEN ;UNDISPLAY PROC QUANTS
ASSERT< WHENNOT XZHE,ZHB
RFAIL PROCEDURE ZHE FOUND NOT ZHB
>
LF (X1)ZHBZQU(XZHE)
LF (X1)ZQUTYP(X1)
SF (X1)ZPCTYP(,XP1-OFFSET(ZPCTYP))
LF(XZHE)ZHBZE(XZHE)
UNDISPLAY
EXCH XZHE,YCAZHE
UNDISPLAY
EXCH XZHE,YCAZHE
ELSE
EXEC CAUNDI ;UNDISPLAY FOLLOWING ZHBZHB CHAIN
EXEC CAPROT ;[40]
FI
LI X6,YCAZMP ;MAKE A MAP
EXEC CAMM
STACK YQRELR
; OUTPUT ZSM?
LI X3,QRELID
EXCH X3,YQRELR
LI QRELST
ST YQRELT
IF LF ,ZHETYP(XZHE)
CAIN QPROCB
GOTO TRUE
CAIE QCLASB
THEN ; OUTPUT ZSMRNM
EXCH XZHE,YCAZHE
LF X2,ZHBZQU(XZHE)
IF IFOFF ZQUGLOB(X2)
THEN ; PRECEDE SYMBOL TABLE WITH LINE NUMBER TABLE POINTER
LI QRELLT
ST YQRELR
L YRELLT
SOS
GENREL
LI QRELID
ST YQRELR
FI
LF ,ZQULID(X2)
GENREL
LF ,ZQULID(X2)
AOS YQRELR ; ASSUMES QRELI2=QRELID+1
GENREL
EXCH XZHE,YCAZHE
FI
L YRELST
ST YCASM
LI QRELST
ST YQRELR
ST YGAP ;[13] TO PREPARE FOR USE OF GENABS
HLRZ YCAZMP ; SYMBOL TABLE(ZSD) POINTER
LF X2,ZHETYP(XZHE)
SF X2,ZSMTYP(X0)
;[13] OUTPUT ZERO AND NOT THE BASE ADDRESS OF THE SYMBOL TABLE
; IF ZSD-POINTER = 0
IF
TRNE X0,-1
THEN
GENABS
ELSE
GENREL
FI
LI QRELST
ST YQRELL
HRRZ X2,YCAQND
SETZ X1,
IF IFOFF YSWD
THEN ; OUTPUT POINTERS TO SYMBOL TABLE
WHILE CAML X2,YDCSTP
DO ; GET A POINTER
LF ,ZMPZSD(X2)
IF SKIPE X1
THEN ;ODD POINTER
HRL X1,
ELSE ; OUTPUT TWO POINTERS
ADD X1
GENREL
SETZ X1,
FI
STEP X2,ZMP
OD
FI
IF SKIPN X1
THEN ;OUTPUT LAST POINTER
SETZM YQRELR
L X1
GENREL
SETZM YQRELL
ELSE
SETZM YQRELR
SETZM YQRELL
SETZ
GENREL
FI
LI QRELPT
ST YQRELT
EXCH X3,YQRELR
LI X5,(X6)
L X6,YRELPT ;REMEMBER WHERE IN PROTOTYPE SECTION
L X2,YCAQND
;--- OUTPUT MAPS TO PROTOTYPE STREAM ---
LI QRELPT ; OUTPUT PROTOTYPES TO PROTOTYPE STREAM
ST YQRELT
ST YGAP
ST YQRELR
LOOP
HRLI X5,-ZMP%S
ASSERT<RIGHTHALF(ZMPZMP)>
ADDM X6,OFFSET(ZMPZMP)(X2)
IF CAMN X6,YRELPT
THEN ; NOT FIRST MAP IN VECTOR
L (X5)
GENREL
ELSE
SETZM (X5)
SUB X5,[1,,1]
FI
WHILE INCR X5,TRUE
DO
L (X5)
GENABS
OD
L X5,X2
STEP X2,ZMP
AS
ASSERT<
CAMLE X2,YDCSTP
GOTO FALSE
WHENNOT X2,ZMP
RFAIL ZMP EXPECTED AT X2
WHENNOT X2,ZMP
GOTO FALSE
>
CAMG X2,YDCSTP
GOTO TRUE
SA
UNSTK YQRELR
LF(XFIX)ZHEFIX(XZHE)
IF ;--CLASS OR PREFIXED BLOCK --
LF(X4) ZHETYP(XZHE)
CAIE X4,QCLASB
CAIN X4,QPBLOCK
GOTO TRUE
THEN
;OUTPUT ANY VIRTUAL DESCRIPTORS (STARTING WITH THE HIGHEST INDEX)
LF(X3) ZHBVRT(XZHE) ;NUMBER OF VIRTUALS
WHILE
SOJGE X3,TRUE ;VIRTUAL INDEXES START AT 0
DO
EXEC CAEBVM ;FIND THE MATCH IF ANY
IF
SKIPN X2,YCAMTC
THEN ;WE HAD A MATCH
LF() ZQUIND(X2) ;LABEL,SWITCH,PROC: FIXUP IN ZQUIND
OP (HRLZI XWAC1,)
GENFIX
ELSE
L [RTSERR QVIRTE]
GENABS
FI
STEP X2,ZQU
OD
;NOTE THAT THE PROTOTYPE IS DEVELOPED ONE WORD AT A TIME IN X0
;AND OUTPUT. THE OFFSET IS USED TO MAKE THE EFFECTIVE ADDRESS
;ZERO, AS IN ZCPZCP(,WOFS) (CHECK GENERATED CODE IN OCTAL).
WOFS==-4
CHKOFS <ZCPZCP>
LF(X1) ZHBZHB(XZHE)
IF
JUMPN X1,TRUE
THEN
LF X1,ZHBZQU(X1)
LF(X1) ZQUIND(X1) ;FIXUP OF PREFIX MUST BE ACCESSED THROUGH ZQU
WSF(X1) ZCPZCP(,-WOFS) ;(OR ZERO) TO X0
GENFIX
ELSE
SETZ
GENABS
FI
NEXTWORD
CHKOFS <ZCPSTA,ZCPKDP>
LI X1,3(XFIX) ;FIXUP FOR 'STATEMENTS'
IFON ZHBKDP(XZHE)
SETONA ZCPKDP(X1)
L X1
GENFIX
NEXTWORD
CHKOFS <ZCPIEA>
LI 4(XFIX)
GENFIX
NEXTWORD
CHKOFS <ZCPSBL,ZCPPRL>
SETZ ;PREFIX LEVEL
L X1,XZHE
LOOP
LF(X1) ZHBZHB(X1)
AS
JUMPE X1,FALSE
LF X3,ZHBNRP(X1)
JUMPE X3,.+2
SETONA ZPCPAR(XP1)
AOJA TRUE
SA
LF(X1) ZHBSBL(XZHE) ;
MOVN X1,X1
SF(X1) ZCPSBL(,-WOFS)
GENABS
FI;--- CLASS OR PREFIXED BLOCK ---
;--- COMMON PART (ZPR) ---
CAIN X4,QPROCB
L XZHE,YCAZHE ; RESET TO ZHE FOR PROCEDURE
L X1,XFIX
LI X2,QRELPT
EXCH X2,YQREL
DEFIX ;DEFINE FIXUP FOR THE PROTOTYPE
EXCH X2,YQREL
WOFS==0
CHKOFS <ZPRBLE,ZPRMAP>
SF(X6) ZPRMAP(,-WOFS) ;LINK TO MAP
LF(X1) ZHELEN(XZHE)
SF(X1) ZPRBLE(,-WOFS)
EXCH X2,YQRELR
GENREL
EXCH X2,YQRELR ; RESTORE QRELCN
NEXTWORD
CHKOFS <ZPREBL,ZPRSYM>
LF(X1) ZHEDLV(XZHE)
SF(X1) ZPREBL(,-WOFS)
LI X2,QRELST
EXCH X2,YQRELR
HRR YCASM
GENREL
EXCH X2,YQRELR
IF ;NOT A SUBBLOCK
CAIN X4,QUBLOCK
THEN ;TREAT ZPC PART
NEXTWORD
CHKOFS <ZPCNRP,ZPCDLE>
LF() ZHBSZD(XZHE)
ADDI 2 ; ACCOUNT FOR OVERHEAD
ASSERT <RIGHTHALF ZPCDLE>
LF(X1) ZHBNRP(XZHE)
JUMPE X1,.+2
SETONA ZPCPAR(XP1)
SF(X1) ZPCNRP(,-WOFS)
GENABS
NEXTWORD
CHKOFS <ZPCDEC>
LI 2(XFIX)
HLL XP1 ; PARAMETER PRESENT BIT IN CLASS PROTOTYPE
GENFIX
;--- FORMAL DESCRIPTORS ---
EXEC CAFQX2
WHILE
RECTYPE(X2) IS ZQU
DO
IF ;A PARAMETER
LF(X1) ZQUMOD(X2)
CAIGE X1,QVIRTUAL
CAIG X1,QDECLARED
THEN ;FORM A DESCRIPTOR IN X3
SETZ X3,
;TYPE, MODE,KIND
LF() ZQUTMK(X2)
SF() ZFPTMK(,X3)
ASSERT <RIGHTHALF ZFPOFS>
LF() ZQUIND(X2)
HLL X3
GENABS
IF ;TYPE REF (ASSUME LEFT HALF)
LF() ZTDTYP(,X3)
CAIE QREF
THEN
LF(X1) ZQUZQU(X2) ;[17] ZHB of qualif. class
LF(X3) ZHBZQU(X2) ;[17] Corresp. ZQU
IF ;[17] System class
IFOFF ZQUSYS(X3)
THEN ;Use 18 bits for fixup
HRRZ OFFSET(ZHEFIX)(X1)
ELSE ;Use normal field
LF() ZHEFIX(X1)
FI ;[17]
GENFIX
FI
FI
STEP X2,ZQU
OD;
FI;
;--- PROTOTYPE FINISHED ---
LI QRELCD ;RESTORE DEFAULT LOCATION COUNTER
ST YGAP
ST YQRELT
L X3,YDCSTP ;SAVE YDCSTP IN CASE OF A CLASS BLOCK
EXEC CAUS
L X1,YCAZHE
LF() ZHETYP(X1)
IF CAIE QCLASB
THEN
ST X3,YDCSTP
ELSE
IF CAIE QPROCB
THEN
ASSERT< WHENNOT X1,ZHB
RFAIL ZHB EXPECTED CAEB
>
LF X3,ZHBZE(X1)
ZF ZHBZE(X1) ; RESET ZHE POINTER
ST X3,YDCSTP
FI
FI
SETZM @YDCSTP
RETURN
EPROC ;--- CAEB ---
COMMENT; ===ROUTINE CAEBVM===
PURPOSE: TO FIND THE LAST VIRTUAL MATCH CORRESPONDING TO
VIRTUAL INDEX (X3) IN A CLASS WITH POSSIBLE PREFIX
CHAIN
ENTRY: EXEC CAEBVM
CALLED RECURSIVELY BY ITSELF THROUGH THE POINT CAEBV.
EXIT: RETURN
;
CAEBVM: PROC
SETZM YCAMTC
SETZM YCALID
CAEBV.: STACK XZHE
LF(XZHE)ZHBZHB(XZHE) ;PREFIX?
JUMPE XZHE,.+2
EXEC CAEBV. ;FIND NEXT PREFIX
UNSTK XZHE
STEP XZHE,ZHB,X2 ;X2 :- NEXT ZQU
WHILE
RECTYPE(X2) IS ZQU
DO
IF
IFON ZQUDD(X2) ;[140]
GOTO FALSE ;[140]
LF() ZQUMOD(X2)
CAIE QVIRTUAL
THEN ;SPEC FOR THIS VIRTUAL OR MATCH FOR ANOTHER?
LF() ZQUNSB(X2) ;A MATCH HAS ZQUNSB > 0
IF
JUMPE TRUE
THEN ;(SPEC)
LF() ZQUIND(X2)
IF
CAIE (X3)
THEN ;SPEC FOR THIS VIRTUAL FOUND
LF() ZQULID(X2)
ST YCALID
ELSE ;[140]
LF() ZQULID(X2)
CAMN YCALID
SETZM YCALID ;Disable further match when redeclared
FI
ELSE ;MATCH?
LF() ZQULID(X2)
IF
CAME YCALID
THEN
ST X2,YCAMTC
FI
FI
FI
STEP X2,ZQU
OD;
RETURN
EPROC
SUBTTL CA DISPATCH TABLE
CAEN: L XZHE,YZHET
GOTO @.-SYMBL2(XCUR)
DEFINE X(A,B,C,D) <
IFL <SYMBL2-B>, <
IFG <SYMBL3-B>, <
A'.>>>
SYMB(6,0,X)
ILSYM.: RFAIL ILLEGAL SYMBOL (CA)
NEXT
SUBTTL CAMM (MAKE MAP OF BLOCK)
COMMENT; === ROUTINE CAMM ===
PURPOSE: CONVERT A SEQUENCE OF ZQU RECORDS TO A ZMP RECORD
(GARBAGE COLLECTOR MAP).
Note that text variables are assumed to follow
"other" variables. The count of text variables
is included in the count for other variables
to simplify initialisation of (reduced) subblocks.
For the benefit of the garbage collector, text variables
are also accounted for separately. The count, in each
instance, is negated and represents the number of words
rather than the number of variables. The format of each
descriptor word is suitable for loop counting.
INPUT: XZHE POINTS TO ZHE OR ZHB OF THE ZQU LIST
X6 POINTS TO WHERE THE MAP IS PUT
ENTRY: EXEC CAMM
EXIT: RETURN
;
CAMM: PROC
SAVE <X2,X3,X4,X5>
XMP=X2 ;BASE OF ZMP RECORD IN REGISTERS
XOV=X3 ;'OTHER' VARIABLES
XRV=X4 ;REF AND ARRAY
XTX=X5 ;TEXT
SETZB X2,X3
IF CAMN XZHE,YCAZHE ; PROC ZHE?
GOTO FALSE
LF ,ZHETYP(XZHE)
CAIE QPROCB
GOTO FALSE
IFOFF YSWD
THEN
; OUTPUT PROC PARMS
L X3,YCAZHE
HRLI X3,ZHB%S(X3)
FI
EXEC CAFQX2 ;FIRST ZQU TO X2
HLL X2,X3
IFON YSWD
EXEC O2SM ; OUTPUT SYMBOLS AND RETURN ZSD POINTER IN YO2ZSD
SETZB XOV,XRV
SETZ XTX,
WHILE
RECTYPE(X2) IS ZQU
DO
IFNEQF X2,ZQUMOD,QDECLARED ;DECLARED VARIABLE?
GOTO L1
LF(X1) ZQUIND(X2)
LF() ZQUKND(X2) ;KIND
CAIN QARRAY
GOTO CAMM.R
CAIE QSIMPLE
GOTO L1
;---SIMPLE VARIABLE, CHECK TYPE ---
LF() ZQUTYP(X2)
CAIN QREF
GOTO CAMM.R
CAIN QTEXT
GOTO CAMM.T
CAIN QLABEL
GOTO L1
;-- SIMPLE, 'OTHER' VARIABLE ---
JUMPN XOV,.+2
SF(X1) ZMPDOV(,XMP)
SUB XOV,[1,,0] ;NEGATIVE COUNT IN LEFT HALF
CAIN QLREAL
SUB XOV,[1,,0] ; TWO WORDS FOR LONG REAL
GOTO L1
CAMM.R: ;--- REF OR ARRAY ---
JUMPN XRV,.+2
SF(X1) ZMPDRV(,XMP)
SUB XRV,[1,,0] ;NEGATIVE COUNT IN LEFT HALF
GOTO L1
CAMM.T: ;--- TEXT VARIABLE ---
JUMPN XTX,.+2
SF(X1) ZMPDTX(,XMP)
SUB XTX,[2,,0] ;TEXT VARIABLE HAS TWO WORDS
L1(): STEP X2,ZQU
OD;
; SET YCAQND
WHILE LF X1,ZDETYP(X2)
SKIPN X1
DO
XCT CAMM.S(X1) ; STEP RECORD
OD
IF SKIPE XOV
THEN ;NO OTHER VARIABLES
L XOV,XTX
ELSE
HLLZ XTX
ADD XOV,
FI
ST X2,YCAQND
HLLZ XMP,YO2ZSD
STD XMP,(X6)
STD XMP+2,2(X6)
CAMM.O: RETURN
; !!! ZHE%V=1,ZHB%V=2,ZQU%V=4
EPROC
CAMM.S: RFAIL CAMMS
STEP X2,ZHE
STEP X2,ZHB
RFAIL CAMMS
STEP X2,ZQU
SUBTTL CACO
COMMENT; === ROUTINE CACO ===
PURPOSE: COPIES ZHB OF THE CLASS THAT IS POINTED TO BY ZHBZHB(XZHE),
THEN COPIES ITS ZQU LIST. THE SAME IS DONE FOR EACH
PREFIX. THE ZHBZHB CHAIN IS UPDATED TO POINT TO THE COPIED
CLASS ETC. ZQUZHE ENTRIES ARE CHANGED TO POINT TO
THE CONNECTION ZHB.
ENTRY: EXEC CACO
EXIT: RETURN
USES: CADISP,M2CO,O2AB,O2LN6,CAUSTD
;
CACO: PROC
SAVE <X2,X3,X4,X5,X6>
SETZ X6,
ASSERT<WHENNOT XZHE,ZHB
RFAIL CACO PARAMETER ERROR
>
L X3,XZHE
L X4,YDCSTP
CAML X4,YDCSTO
EXEC M2CO ; MORE CORE NEEDED
LI X1,-1(X4)
LF ,ZHBZHB(X3)
CAML YDCSTB
CAML YDCSTP
BRANCH O2AB ; NO RECOVERY IF INSPECTED CLASS UNKNOWN
WHILE
LF(X5) ZHBZHB(X3)
JUMPN X5,TRUE
DO
ASSERT< WHENNOT X5,ZHB
RFAIL ZHBZHB LINKS ERROR CACO
>
STEP X1,ZHB
STEP X5,ZHB,X2
;/COPY ZHB/;
HRLI (X5)
HRRI (X4)
BLT (X1)
SKIPE X6
SF X4,ZHBZHB(X6) ;INSERT PREFIX OF COPY
L X6,X4
STEP X4,ZHB
CAML X4,YDCSTO
EXEC M2CO
WHILE
RECTYPE(X2) IS ZQU
DO
STEP X1,ZQU
;/COPY ZQU/;
HRLI (X2)
HRRI (X4)
BLT (X1)
SF(XZHE)ZQUZHE(X4) ;NEW ZQUZHE
SETON ZQUIS(X4)
LI X4,1(X1)
STEP X2,ZQU
CAML X4,YDCSTO
EXEC M2CO
OD
L X3,X5
OD
L YDCSTP
CAMN X4
SETZ
SF ,ZHBZHB(XZHE)
IFON YSWI
EXEC O2LN6
SETZM (X4)
EXEC CADISP ;DISPLAY PREFIXES, THEN CLASS, THEN CONNECTION
ASSERT< CAML X4,YDCSTO
RFAIL DECL. STACK OVERFLOW
>
ST X4,YDCSTP
EXEC CAUSTD
RETURN
EPROC
SUBTTL CAPL,CAUS
COMMENT; === ROUTINE CAPL ===
PURPOSE: COMPUTE PREFIX LEVEL OF CLASS TO WHOSE ZHB RECORD XZHE POINTS,
AND COMPILE: MOVEI XSAC,prefix level
ENTRY: EXEC CAPL
NORMAL EXIT: RETURN
INPUT: XZHE, POINTS TO ZHB OF CLASS
USED ROUTINE: O2GA
;
CAPL: PROC
SETZ ;PREFIX LEVEL TO X0
L X1,XZHE
LOOP
LF(X1) ZHBZHB(X1)
AS
JUMPE X1,FALSE
AOJA TRUE
SA
OP (MOVEI XSAC,)
GENABS
RETURN
EPROC
COMMENT; === ROUTINE CAUS ===
PURPOSE: STACK DOWN BLOCK STACK, DECLARATION STACK
AND REDECLARATION STACK.
UPDATE XZHE AND YZHET.
CALL: EXEC CAUS
EXIT: RETURN
;
CAUS: PROC
L X1,YBKSTP ;STACK DOWN BLOCK STACK
POP X1,X0
HRRZM YDCSTP
HLRZM YRDSTP
HRRZ (X1)
ST YZHET
ST XZHE
ST X1,YBKSTP
RETURN
EPROC
SUBTTL CARDX3,CAFQX2
;--- SMALL AUXILIARY ROUTINES ---
CARDX3: ;--- FORMS REDECLARATION STACK POINTER IN X3 ---
HRRZ X3,YRDSTP
SUB X3,YRDSTO
HRL X3,X3
HRR X3,YRDSTP
RETURN
CAFQX2: ;--- MAKES X2 POINT TO FIRST ZQU RECORD ---
STEP XZHE,ZHE,X2
WHEN XZHE,ZHB
STEP XZHE,ZHB,X2
RETURN
SUBTTL CADS (DISPLAY)
COMMENT; === ROUTINE CADS ===
PURPOSE: DISPLAY ZQU LIST POINTED TO BY XZHE INTO THE DICTIONARY,
PUSHING OLD DECLARATIONS INTO REDECLARATION STACK.
ENTRY: EXEC CADS
EXIT: RETURN
;
CADS: PROC
SAVE <X2,X3>
IFN QDEBUG,<
IF IFOFF SCADB5
THEN
EXEC O2DB1,<<[020000,,0]>> ; NEW LINE ON DEBUG FILE
HRL XZHE
EXEC O2DB3,<<[610000,,'DIS']>,X0>
FI
>
EXEC CAFQX2 ;STEP X2 TO ZQU RECORD
EXEC CARDX3 ;FORM REDECL STACK POINTER IN X3
WHILE
RECTYPE(X2) IS ZQU
DO
LF(X1) ZQULID(X2)
JUMPE X1,CADS.2
IFON ZQUIVA(X2) ;[40]
GOTO CADS.2 ;DONT DISPLAY IF INVISIBLE[40]
IFN QDEBUG,<
IF IFOFF SCADB5
THEN ; DEBUG OUTPUT
HRLI X1,300000
EXEC O2DB2,<X1>
HRRZ X1,X1
FI
>
WLF() ZDCZDC(X1,YDICTB)
JUMPE CADS.1
PUSH X3, ;SAVE OLD DECL
SF(X3) ZDCZDC(X1,YDICTB) ;AND REMEMBER WHERE.
CADS.1: IF ;[136]
IFON ZQUDD(X2) ;[136]
THEN ;[136]
SF(X2) ZDCZQU(X1,YDICTB) ;STORE NEW ZQU POINTER
ELSE ;[136]
SETF YUNDEC,ZDCZQU(X1,YDICTB) ;[136]
FI ;[136]
CADS.2: STEP X2,ZQU
OD;
ST X3,YRDSTP
RETURN
EPROC
SUBTTL CAUD (UNDISPLAY)
COMMENT; === ROUTINE CAUD ===
PURPOSE: UNDISPLAY ZQU LIST STARTED BY ZHE OR ZHB RECORD POINTED TO
BY XZHE, RESTORING REDECLARED QUANTITIES.
ENTRY: EXEC CAUD
EXIT: RETURN
;
CAUD: PROC
SAVE X2
IFN QDEBUG,<
IF IFOFF SCADB5
THEN
EXEC O2DB1,<<[020000,,0]>> ; NEW LINE ON DEBUG FILE
HRL XZHE
EXEC O2DB3,<<[610000,,'UDS']>,X0>
FI
>
EXEC CAFQX2 ;GET FIRST ZQU TO X2
WHILE
RECTYPE(X2) IS ZQU
DO
LF(X1) ZQULID(X2)
IF
IFOFF ZQUIVA(X2) ;[40] Not displayed if invisible
SKIPN X1
THEN
IFN QDEBUG,<
IF IFOFF SCADB5
THEN ; DEBUG OUTPUT
HRLI X1,300000
EXEC O2DB2,<X1>
HRRZ X1,X1
FI
>
LF() ZDCZDC(X1,YDICTB) ;ANY REDECLARATION FOR THIS QUANTITY?
JUMPE .+2 ;IF NOT, STORE ZERO IN DICTIONARY,
L @ ;OTHERWISE RESTORE OLD DECLARATION
WSF() ZDCZDC(X1,YDICTB)
FI
STEP X2,ZQU
OD;
RETURN
EPROC
SUBTTL CADISP,CAUNDI
CADISP: PROC ;DISPLAY PREFIXES, THEN THE CLASS OR PREFIXED BLOCK
STACK XZHE
LF(XZHE)ZHBZHB(XZHE)
JUMPE XZHE,.+2
EXEC CADISP ;RECURSIVE CALL
UNSTK XZHE
DISPLAY
RETURN
EPROC
CAUNDI: PROC ;UNDISPLAY A BLOCK AND POSSIBLE PREFIXES
;WORKS ALSO FOR CONNECTION BLOCK
SAVE <XZHE>
IF
RECTYPE(XZHE) IS ZHE
THEN
UNDISPLAY
ELSE
LOOP
UNDISPLAY
LF(XZHE)ZHBZHB(XZHE)
AS
JUMPN XZHE,TRUE
SA
FI
RETURN
EPROC
CAUSTD: PROC ; UPDATE ZHBSTD ON ENTRY AND EXIT TO
; FOR STATMT, INSPECTION AND UNREDUCED SUBBLOCK
SAVE <X2,X3>
L X2,YZHET
L X3,YZHBXC
ASSERT< WHENNOT X3,ZHB
RFAIL NOT ZHB AT YZHBXCB
>
LF X1,ZHEDLV(X2) ; NEW TOP
MOVN X1,X1
ADDI X1,1
LF ,ZHBSTD(X3)
LF X2,ZHBSZD(X3)
CAIG X2,(X1)
SF X1,ZHBSZD(X3)
SF X1,ZHBSTD(X3)
CAIL X1,QMAXDIS
ERROR2 50,DISPLAY SIZE OVERFLOW
RETURN
EPROC
SUBTTL CAUNPR [40]
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FUNCTION: Make all protected attributes accessible and hide
hidden attributes. If FLAG is zero then check
own HIDDEN specifications.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
CAUNPR: PROC <FLAG>
SAVE <X1,X2,X3,X4,X5,XZHE>
EXEC CAUNP1
EXEC CAUNP2
WHEN X2,ZQU
SKIPE FLAG
SKIPA
EXEC CAUNP3
RETURN
EPROC
CAUNP1: PROC
SAVE XZHE
LF XZHE,ZHBZHB(XZHE)
IF SKIPN XZHE
THEN
EXEC CAUNP1
EXEC CAUNP2
WHEN X2,ZQU
EXEC CAUNP4
FI
RETURN
EPROC
CAUNP2: PROC
STEP XZHE,ZHB,X2
WHILE
WHENNOT X2,ZQU
DO
IF IFOFF ZQUIVA(X2)
THEN
IFOFF ZQUPTD(X2)
RETURN ;X2 POINTS TO FIRST HIDDEN SPEC
SETOFF ZQUIVA(X2)
FI
STEP X2,ZQU
OD
RETURN
EPROC
CAUNP3: PROC
LI X5,0 ;[140]
WHILE
EXEC CAUNP5
SKIPN X3
DO
IF JUMPE X4,FALSE ;[140]
IFON ZQUUSE(X4) ;[140]
THEN
SETON ZQUUSE(X4)
IF
IFON ZQUNOT(X2)
;[140] GOTO [JUMPE X4,TRUE
;[140] GOTO FALSE]
;[140] JUMPN X4,TRUE
THEN
IFOFF ZQUPTD(X3)
EXEC CAE421
FI ;[140]
FI
OD
LOOP
IFOFF ZQUUSE(X2)
EXEC CAE422
SETOFF ZQUUSE(X2)
STEP X2,ZQU
AS
WHEN X2,ZQU
GOTO TRUE
SA
RETURN
EPROC
CAUNP4: PROC
LI X5,0 ;[140]
WHILE
EXEC CAUNP5
SKIPN X3
DO
;[140]
IF IFON ZQUNOT(X2)
THEN ;HIDDEN
IF JUMPE X4,FALSE
IFON ZQUUSE(X4)
THEN
IF IFOFF ZQUPTD(X3)
THEN
SETON ZQUIVA(X3)
FI
IF IFNEQF X3,ZQUMOD,QVIRTUAL
GOTO TRUE
IFNEQF X3,ZQUNSB,0
THEN ;Not virtual match
SETON ZQUUSE(X4)
FI
FI
ELSE ;NOT HIDDEN
IF SKIPE X4
THEN ;ZQU not in list
IF IFOFF ZQUUSE(X3)
THEN
SETOFF ZQUUSE(X3)
ELSE
IF IFOFF ZQUPTD(X3)
THEN
SETON ZQUIVA(X3)
FI
IF IFNEQF X3,ZQUMOD,QVIRTUAL
GOTO TRUE
IFNEQF X3,ZQUNSB,0
THEN ;Set use bit
STACK X1
STACK X2
STACK X3
STACK X4
LF X3,ZQULID(X3)
L X2,XZHE
WHILE
SKIPN X2
DO
STEP X2,ZHB,X1
WHILE
WHENNOT X1,ZQU
DO
LF X4,ZQULID(X1)
IF
IFOFF ZQUIVA(X1)
CAME X3,X4
THEN
SETON ZQUUSE(X1)
FI
STEP X1,ZQU
OD
LF X2,ZHBZHB(X2)
OD
UNSTK X4
UNSTK X3
UNSTK X2
UNSTK X1
FI
FI
FI
FI
OD
LOOP
SETOFF ZQUUSE(X2)
STEP X2,ZQU
AS
WHEN X2,ZQU
GOTO TRUE
SA
REPEAT 0,<[140]
IF
IFON ZQUNOT(X2)
GOTO [JUMPE X4,TRUE
GOTO FALSE]
JUMPN X4,TRUE
THEN ;HIDE
IF IFOFF ZQUPTD(X3) ;ERROR ALREADY GENERATED
THEN
SETON ZQUIVA(X3)
FI
FI
OD
>;[140]
RETURN
EPROC
CAUNP5: PROC
;[140]
; Get next visible ZQU
WHILE SKIPE X5
DO
LI X3,0
SKIPN XZHE
RETURN ;All ZQU consumed
STEP XZHE,ZHB,X3
LF XZHE,ZHBZHB(XZHE)
WHILE WHENNOT X3,ZQU
DO
ADDI X5,1
STEP X3,ZQU
OD
OD
SUBI X3,ZQU%S
SUBI X5,1
REPEAT 0,<[140]
IF SKIPE X3
THEN
STEP XZHE,ZHB,X3
ELSE
STEP X3,ZQU
FI
IF
WHEN X3,ZQU
THEN
LI X3,0
LF XZHE,ZHBZHB(XZHE)
JUMPN XZHE,CAUNP5
RETURN
FI
>;[140]
IFON ZQUIVA(X3)
GOTO CAUNP5
L X4,X2
LF X1,ZQULID(X3)
WHILE
WHENNOT X4,ZQU
DO
LF ,ZQULID(X4)
CAMN X1
RETURN
STEP X4,ZQU
OD
LI X4,0
RETURN
EPROC
CAE421: PROC
LF ,ZQULNE(X2)
SKIPE X4
LF ,ZQULNE(X4)
ST YELIN1
ST YELIN2
LF X1,ZQULID(X3)
ERRI1 QE,421 ;Attribute XXXX hidden but not protected
RETURN
EPROC
CAE422: PROC
LF ,ZQULNE(X2)
ST YELIN1
ST YELIN2
LF X1,ZQULID(X2)
ERRI1 QE,422 ;No attribute XXXX visible
RETURN
EPROC
SUBTTL CAPROT [40]
COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
FUNCTION: Make all protected attributes in this class and
its prefix classes inaccessible.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
CAPROT: PROC
WHENNOT XZHE,ZHB
RETURN
SAVE <X1,XZHE>
STEP XZHE,ZHB,X1
WHILE
WHENNOT X1,ZQU
DO
IF IFOFF ZQUPTD(X1)
THEN
SETON ZQUIVA(X1)
FI
STEP X1,ZQU
OD
LF XZHE,ZHBZHB(XZHE)
SKIPE XZHE
EXEC CAPROT
RETURN
EPROC
SUBTTL BBLK, --- BEGIN SUBBLOCK ---
BBLK.: COMMENT; --- CODE FOR BEGIN OF SUBBLOCK -
READ DECLARATION LIST FROM DF1,
EMIT CODE FOR BLOCK ENTRY
;
EXEC CARL ;READ QUANTS FOR BLOCK INTO DECLARATION STACK
ASSERT <WHENNOT (XZHE,ZHE)
RFAIL ZHE RECORD EXPECTED
>
IF LI X2,ZHE%S(XZHE)
CAME X2,YDCSTP
THEN ;NO ZQUS IN LIST: INSERT DUMMY ZQU
SETZM X0
SETZM X1
STD X0,(X2)
STD X0,2(X2)
LI ZQU%V
SF ,ZDETYP(X2)
LI ZQU%S(X2)
ST YDCSTP
FI
LF() ZHETYP(XZHE)
ASSERT <CAIL QRBLOCK ;ASSUME QUBLOCK=QRBLOCK+1
CAILE QUBLOCK
RFAIL SUBBLOCK EXPECTED
>
IF ;UNREDUCED SUBBLOCK
CAIE QUBLOCK
THEN
EXEC O2LN1
LF() ZHEFIX(XZHE) ;FIXUP FOR SUBBLOCK PROTOTYPE
OP (MOVEI XSAC,) ;/ MOVEI XSAC,prototype /;
GENFIX ;/ PUSHJ XPDP,CSSB /;
EXEC CAUSTD
GPUSHJ CSSB
ELSE
LF() ZHEBNM(XZHE) ;BLOCK STATE NUMBER
OP (MOVEI XSAC,)
GENABS
IF CAMN XZHE,YZHBXC
THEN ; CURRENT BLOCK NOT ADDRESSABLE BY XCB?
L X1,YBKSTP
WHILE LF ,ZHETYP(XZHE)
CAIE QFOR ; SKIP FOR STATEMENTS
DO
POP X1,XZHE
OD
LF ,ZHEDLV(XZHE)
L X1,YZHBXCB
LF X1,ZHEDLV(X1)
CAMN X1
GOTO FALSE ; OUT FROM IF-THEN
LF ,ZHEDLV(XZHE)
OP (HRL XSAC,(XCB))
GENABS
FI
GPUSHJ CSER
IFON YSWI
EXEC O2LN5
FI
EXEC O2DFTE ;[6] OUTPUT TENTATIVE FIXUP IF ANY
NEXT
SUBTTL BPROG, DEBUG, DO
BPROG.: ASSERT< L YDCSTP
CAME YDCSTB
RFAIL BPROG NOT FIRST SYMBOL IN IC1
>
; READ STANDARD QUANTITIES USED IN THIS PROGRAM
EXEC CARL
LI 2
SF ,ZHEEBL(XZHE)
; ALLOCATE OUTERMOST BLOCK
IF IFON YSWCE
THEN ; OUTERMOST BLOCK IS REDUCED SUBBLOCK
L X3,YMPSIZ
SF X3,ZHELEN(XZHE)
L X2,YRELCD
ADDI X2,<QMAXDIS-1>
MOVSI <<QZDR>B<%ZDNTYP+^D18>>
GENABS ; ZDN WORD
LI QMAXDIS+1
GENABS ; ZDR RECORD LENGTH
LOOP SETZ
GENABS
AS CAME X2,YRELCD
GOTO TRUE
SA
LI 2(X2)
ST YCABKB
GENRLD ; DISPLAY ELEMENT
SETZ
GENABS ; RETAD-BLOCKAD ZERO IN OUTERMOST BLOCK
; BLOCK STARTS HERE
L X4,YRELCD
HRLZI X0,<1B<%ZDNDET+^D18>+<QZPB>B<%ZDNTYP+^D18>> ; ZBIBNM ZERO
GENABS
L X2,YDCSTB
LF ,ZHEFIX(X2)
GENFIX ; FIRST ZBI WORD WITH PROTOTYPE ADDRESS
LI QMAXDIS-3
SF ,ZHBSZD(X2)
LOOP SETZ
GENABS
AS SOJG X3,TRUE
SA
EXEC O2LN1 ; FIRST PROTOTYPE ENTRY
EXEC O2LN2 ; FIRST ENTRY OF LINE TABLE FOR MODULE
L X3,YRELCD
IF ;[144] No runswitches
SKIPE YSWRF
THEN ;Indicate by negative X3 value
SETO X3,
ELSE ;Output the block to REL file
L X2,[-4,,YSWRF]
LOOP ;Output dev:file.ext + one word
L (X2)
GENABS
AS
AOBJN X2,TRUE
SA
L (X2) ;PPN or SFD addr
IF ;SFD
JUMPE FALSE
TLNE -1
THEN ;Relocated address of SFD list
L YRELCD
ADDI 4 ;Follows runswitches
GENRLD
HRL X3,(X2) ;Save SFD table address
ELSE ;Abs word
GENABS
FI
L X2,[-3,,YSWRF+5]
LOOP
L (X2)
GENABS
AS AOBJN X2,TRUE
SA
IF ;SFD list should follow
TLNN X3,-1
THEN ;Copy up to final zero
HLRZ X2,X3
L (X2)
GENABS
L 1(X2)
GENABS
LOOP
L 2(X2)
GENABS
AS SKIPE 2(X2)
AOJA X2,TRUE
SA
FI
FI ;[144]
; GENERATE INITIALIZING SEQUENCE
L YRELCD ; SAVE ENTRY POINT
ST YCANTRY
L [JRST 1,1]
ADD YRELCD
GENRLD
L [TDZA 1,1]
GENABS
L [JRST 1,1]
ADD YRELCD
GENRLD
OPZ (LI XCB,)
HRR X4
GENRLD
OPZ (JSP 16,)
HRRI OCSP
GENFIX
OPZ (NOP)
IF SKIPL X3
THEN ; NO RUNSWITCH
GENABS
ELSE
HRR X3
GENRLD
FI
FI
L YDCSTB
ST YZHBXC
LI X1,QIDTXT
LF ,ZDCZQU(X1,YDICTB)
ASSERT<SKIPN X0
RFAIL TEXT MISSING IN DICT
>
ST YTEXTI
L X4,XZHE
IF SKIPN XZHE,YDICTB+QIDSIN
THEN
ST XZHE,YSYSI
LF XZHE,ZQUZQU(XZHE)
LF XZHE,ZQUZB(XZHE)
HRR X5,XZHE
ASSERT<
ELSE
OUTSTR [ASCIZ/SYSIN MISSING/]
>
FI
IF SKIPN XZHE,YDICTB+QIDSUT
THEN
LF XZHE,ZQUZQU(XZHE)
LF XZHE,ZQUZB(XZHE)
HRL X5,XZHE
FI
;[176] L XZHE,X4
;[176] IFON YSWCE
;[176] EXEC CAUD
HRR XZHE,X5
EXEC CADISP
HLR XZHE,X5
EXEC CADISP
L XZHE,X4
;[176] IFON YSWCE
;[176] EXEC CADISP
IF SKIPN X1,YDICTB+QIDSIM
THEN
LF X1,ZQUZB(X1)
STEP X1,ZHB
WHILE LF X2,ZQULID(X1)
CAIN X2,QIDPRO
DO
STEP X1,ZQU
ASSERT<
CAML X1,YDCSTO
RFAIL PROCESS ZQU NEVER FOUND
>
OD
ST X1,YPROCI
ELSE
OUTSTR [ASCIZ/SIMULATION MISSING/]
FI
EXEC CAUSTD
LI X2,QRELST
EXCH X2,YGAP
GENABS
EXCH X2,YGAP
IFON YSWCE ;[176]
EXEC CARL ;[176]
NEXT
IFN QDEBUG, <
EXTERN CADB
DEBUG.= CADB
>
IFE QDEBUG, <
DEBUG.= ILSYM.
>
DO.: ;--- INSPECT <object expression> DO ---
;READ ZHB AND POSSIBLE LABEL LIST.
;COPY ZHB-ZQU LISTS OF INSPECTED CLASS AND ANY PREFIXES,
;THEN DISPLAY CLASS (AFTER PREFIXES), THEN DISPLAY LABEL LIST.
EXEC CARL
ASSERT< WHENNOT XZHE,ZHB
RFAIL DOZHB NOT FOUND
>
UNDISPLAY ;DEFER DISPLAY OF LABEL LIST
L X1,YORZQU
SF X1,ZHBZQU(XZHE)
SETZM YORZQU
LF() ZQUZB(X1)
SF() ZHBZHB(XZHE)
LF ,ZHEDLV(XZHE)
OP (ST XWAC1,(XCB))
GENABS
BRANCH CACO
SUBTTL EBLK
EBLK.: ;--- END OF SUBBLOCK ---
ASSERT <WHENNOT (XZHE,ZHE)
RFAIL ZHE RECORD EXPECTED
>
LF() ZHETYP(XZHE)
ASSERT <CAIL QRBLOCK
CAILE QUBLOCK
RFAIL SUBBLOCK EXPECTED
>
IF
CAIE QUBLOCK
THEN
;--UNREDUCED SUBBLOCK
QSADEA=1
IFE QSADEA,<
; OLD CODE, NO DEALLOCATION BEFORE GC
LF() ZHEDLV(XZHE) ;CODE TO CLEAR DISPLAY ENTRY
OP (SETZM (XCB))
GENABS
>
IFN QSADEA,<
QINLIN=0
QSUBR=1
IFG QINLIN,<
;DEALLOCATION DONE BY INLINE CODE
L [SETZ XTAC,]
GENABS
LF ,ZHEDLV(XZHE)
OP (EXCH XTAC,(XCB))
GENABS ;CLEAR DISPLAY AND GET RECORD TO XTAC
L [LOWADR(XWAC2)]
GENABS
L [CAMG XTAC,YSADEA(XWAC2)]
GENABS
L YRELCD
ADDI 6
OP (JRST)
EXEC CGRD
L [HRRI XSAC,1(XTAC)]
GENABS
L [SETZM (XTAC)]
GENABS
L [HRL XSAC,XTAC]
GENABS
L [BLT XSAC,@YSATOP(XWAC2)]
GENABS
L [HRRZM XTAC,YSATOP(XWAC2)]
GENABS
>
IFG QSUBR,<
LF ,ZHEDLV(XZHE)
OP (MOVEI XSAC,(XCB))
GENABS
GPUSHJ CSEU
>
>
EXEC CAEB ;UNDISPLAY,OUTPUT PROTOTYPE AND MAP
EXEC CAUSTD
NEXT
FI
;--REDUCED SUBBLOCK --
IFON YSWI
EXEC O2LN4
UNDISPLAY
;--Make map of subblock
;--SQUEEZE OUT QUANTS, LEAVE ZMP RECORDS
L X6,XZHE
EXEC CAMM ;LEAVE POINTER TO END OF QUANTS IN YCAQND
STEP XZHE,ZMP
L X2,XZHE
L X1,YDCSTP ;DECL STACK TOP
SUB X1,YCAQND ;- END OF QUANTS => LENGTH OF CHUNK
IF
JUMPG X1,TRUE ; TO MOVE, IF ANY
THEN
HRL X2,YCAQND ;FORM BLT WORD IN X2
ADDI X1,(XZHE)
BLT X2,(X1) ;MOVE IT
SUB X6,YCAQND ;-LENGTH OF SKIPPED DATA
ADD X6,YDCSTP ;DECREASE STACK POINTER
FI
L X3,YZHET ; WHERE THE MAP WAS JUST PUT
EXEC CAUS
LF X2,ZHEBNM(XZHE)
ASH X2,2
SF X2,ZMPZMP(X3)
STEP X6,ZMP
SETZM (X6)
ST X6,YDCSTP
; CODE TO UPDATE BLOCK STATE
LF() ZHEBNM(XZHE)
OP (MOVEI XSAC,)
GENABS
IF L X1,YZHBXC
LF X1,ZHEDLV(X1)
LF ,ZHEDLV(XZHE)
CAME X1
THEN ; XCB POINTS TO BASE
L [$ZBIBNM(XCB)]
ELSE
OP (L XTAC,(XCB))
GENABS
L [$ZBIBNM(XTAC)]
FI
GENWRD
OP (DPB XSAC,)
GENREL
ASSERT< LF ,ZHETYP(XZHE)
CAIN QFOR
RFAIL REDUCTION PAST FOR
CAIN QCLASB
RFAIL REDUCTION INTO CLASS
CAIN QINSPE
RFAIL REDUCTION PAST INSPECT
>
NEXT
SUBTTL EDCL, EDPB
EDCL.: ;--- END OF DECLARATIONS IN A CLASS
COMMENT; DEFINE FIXUP F+3, WHERE F IS BASE FIXUP OF CLASS.
OUTPUT A CALL ON CPCD
;
EXEC CAPL ;COMPILE /MOVEI XSAC,prefix level/
GJRST CPCD
LF(X1) ZHEFIX(XZHE) ;DEFINE ZHEFIX+3 OF THIS CLASS
ADDI X1,3
DEFIX
NEXT
EDPB.: ;--- END DECLARATIONS IN A PREFIXED BLOCK
COMMENT; DEFINE FIXUP+5 OF PREFIXED BLOCK
OUTPUT CALL ON CPPD
;
GJRST CPPD
LF(X1) ZHEFIX(XZHE)
ADDI X1,3
DEFIX
NEXT
SUBTTL ENDCL
ENDCL.: COMMENT; --- END OF CLASS BODY ---
GENERATE CLASS EXIT CODE. MAKE A TENTATIVE DEFINITION
OF FIXUP F+5 FOR THE CLASS.
UNDISPLAY CLASS ATTRIBUTES.
OUTPUT PROTOTYPE AND MAP.
;
EXEC CPEND
IF SKIPE X2
THEN
GJRST CPE0
FI
LF(X2) ZHEFIX(XZHE)
EXEC CAEB ;OUTPUT PROTOTYPE AND MAP, STACK DOWN BLOCK STACK
LI X1,5(X2)
HRROS YTENT ;TENTATIVE FIXUP DEFINITION (F+5)
DEFIX
NEXT
SUBTTL CPEND
CPEND: ;FIND OUT IF ANY PREFIX HAS AN EXPLICIT INNER AND COMPILE
;A JUMP TO STATEMENTS AFTER INNER, OTHERWISE X2 IS 0 ON
;RETURN.
L X1,XZHE
LOOP
LF(X2) ZHBZHB(X1) ;PREFIX?
JUMPE X2,FALSE
L X1,X2
IFON ZHENOI(X1) ;IF NO INNER IN PREFIX, TRY NEXT PREFIX
GOTO TRUE
LF X2,ZHBZQU(X1)
IF
IFON ZQUSYS(X2) ; SYSTEM PREFIX
GOTO FALSE
IFON ZHBEXT(X1) ;CHECK FOR EXTERNAL PREFIX
THEN ;-- NORMAL PREFIX, COMPILE JRST TO INSTR AFTER INNER
;-- IN PREFIX --
LF(X2) ZQUIND(X2)
LI 4(X2)
OP (JRST)
GENFIX
ELSE ;-- PREFIX EXTERNAL, COMPILE JRST THROUGH PROTOTYPE --
LF(X2) ZQUIND(X2)
LI (X2)
OP (MOVEI XSAC,)
GENFIX
L [JRST @OFFSET(ZCPIEA)(XSAC)]
GENABS
FI
AS SA
RETURN
SUBTTL ENDDO,ENDFO
ENDDO.: ;--- END OF DO CLAUSE IN INSPECTION ---
; CLEAR DISPLAY ELEMENT
OPZ (SETZ XWAC1,)
GENABS
LF ,ZHEDLV(XZHE)
OP (EXCH XWAC1,(XCB))
GENABS
LF(X2) ZHEFIX(XZHE)
ST X2,YORFX
LI 3(X2) ;COMPILE JRST TO END OF
OP (JRST) ;INSPECTION
GENFIX
LI X1,2(X2) ;DEFINE AND RELEASE FIXUP F+2
DEFIX
LI X1,2(X2)
CLFIX
EXEC O2AF ; ALLOCATE IT AGAIN FOR NEXT WHEN CLAUSE
LF() ZHBZQU(XZHE)
ST YORZQU ;SAVE ZQU OF QUALIFYING CLASS
LF() ZHBZHB(XZHE) ;AND ZHB OF DECLARING CLASS
ST YORZHB
EXEC CAUNDI ;UNDISPLAY, FOLLOWING ZHB CHAIN,
IFON YSWI
EXEC O2LN4
LI X1,1(X2)
CLFIX ; CLEAR AND REALLOCATE FIX FOR LINE TABLE
LI X1,1(X2)
EXEC O2AF
EXEC CAUS ;THEN UNSTACK THE CONNECTION BLOCK
NEXT
ENDFO.: ;--- END OF FOR STATEMENT ---
;COMPILE CODE TO GO BACK TO FOR LIST, THEN DEFINE FIXUP F+1.
;UNDISPLAY LABEL LIST, REMOVE FOR STATEMENT ENTRY FROM STACKS.
LF() ZHEDLV(XZHE) ;DISPL. OF FOR RETURN ADDRESS LOCATION
OP (JRST @(XCB))
GENABS
LF(X2) ZHEFIX(XZHE) ;DEFINE F+1
LI X1,1(X2)
DEFIX
L X1,X2 ;CLEAR F, F+1 FOR REUSE
CLFIX
LI X1,1(X2)
CLFIX
UNDISPLAY
EXEC CAUS
EXEC CAUSTD
SETZM @YDCSTP
NEXT
SUBTTL ENDPR,EPROG,ERROR
ENDPR.: ;--- END PROCEDURE ---
;COMPILE RETURN FOR PURE PROCEDURE, CALL ON CSEP FOR TYPE PROCEDURE.
;DEFINE FIXUP F+3 TENTATIVELY, RELEASE F+1, F+2.
;OUTPUT PROCEDURE PROTOTYPE WITH MAPS OF ENCLOSED,
;REDUCED SUBBLOCKS.
ASSERT< WHENNOT XZHE,ZHB
RFAIL NOT ZHB AT ENDPROC
>
LF(X1) ZHBZQU(XZHE)
SETOFF ZQUIB(X1)
IF
LF() ZQUTYP(X1)
CAIE QNOTYPE ;NOTYPE PROCEDURE?
THEN
IFE QSADEA,<
L X2,[-3,,[MOVE XSAC,OFFSET(ZDRARE)(XCB) ;RET ADDR AND B.I. ADDR
HLRZ XCB,XSAC ;RESTORE XCB
JRST (XSAC)]] ;EXIT
LOOP
L (X2)
GENABS
AS
INCR X2,TRUE
SA
>
GJRST(CSES) ;SAME AS SWITCH THUNK EXIT
ELSE ;-- TYPE PROCEDURE --
GJRST CSEP
FI
LF(X2) ZHEFIX(XZHE)
EXEC CAEB
LI X1,3(X2)
HRROS YTENT
DEFIX
LI X1,1(X2)
CLFIX
LI X1,2(X2)
CLFIX
NEXT
EPROG.:
L XZHE,YDCSTB
IF IFON YSWCE
THEN ; OUTPUT OUTERMOST PROTOTYPE
EXEC O2LN2 ; LAST LINE NUMBER ENTRY
L X2,YDCSTB
LF X2,ZHEFIX(X2)
LI X1,2(X2)
DEFIX
LI X1,3(X2)
DEFIX
LI X1,4(X2)
DEFIX
EXEC CAEB
GPUSHJ(OCEP)
FI
BRANCH O2EX ;--- END OF PROGRAM ---
ERROR.: ;--- SET FLAG TO GENERATE RTS ERROR INSTEAD OF CODE FOR CURRENT TREE ---
SETON SCERFL
L [RTSERR QDSCON,QSORCERROR] ;[41]
GENABS
NEXT
SUBTTL FIX,FORDO,IENDC,INNER,JUMP
FIX.: ;--- DEFINE FIXUP VALUE ---
INVAL
L X1,X0
DEFIX
NEXT
FORDO.: ;--- DO OF FOR STATEMENT ---
;COMPILE JUMP TO FIXUP F+1
;DEFINE AND RELEASE (F+2)
;IF ANY SIMPLE FOR LIST ELEMENT WAS PRESENT,
;COMPILE INSTR TO SAVE RET ADDR:
; MOVEM XSAC,RETURN ADDR(XCB)
;DISPLAY LABEL LIST, DEFINE FIXUP F,
;REMOVE NODE FOR CONTROLLED VAR FROM OPERAND STACK
LF(X2) ZHEFIX(XZHE)
LI 1(X2)
OP (JRST)
GENFIX
LI X1,2(X2)
DEFIX
CLFIX
IF
SKIPN YFORSI
THEN
LF ,ZHEDLV(XZHE)
OP (MOVEM XSAC,(XCB))
GENABS
FI
DISPLAY
LI X1,(X2)
DEFIX
L [QOPSTZ,,YOPST-1]
ST YOPSTP
;[30] EXEC CAUSTD ;MOVED TO CVBE. (OR)
NEXT
IENDC.: ;--- END OF CLASS WITH NO EXPLICIT "INNER"
;SET ZHENOI, THEN DO ACTIONS FOR INNER AND ENDCL.
SETON ZHENOI(XZHE)
EXEC INNER.
BRANCH ENDCL. ;RETURN FROM CA MODULE VIA ENDCL.
INNER.: ;--- "INNER" STATEMENT ---
;OUTPUT CALL ON CPCI, DEFINE ZHEFIX+4
EXEC CAPL ;COMPILE /MOVEI XSAC,prefix level/
GJRST(CPCI)
LF(X1) ZHEFIX(XZHE)
ADDI X1,4
DEFIX
NEXT
JUMP.: ;--- COMPILE JRST TO FIXUP FOLLOWING ---
INVAL
OP (JRST)
GENFIX
NEXT
SUBTTL NOTHR,OPT,OTHER
NOTHR.: ;--- END OF INSPECTION WITHOUT OTHERWISE CLAUSE ---
EXEC OTHER.
LI X1,3(X2)
DEFIX ;DEFINE FIXUP F+3 (END OF INSPECTION)
NEXT
OPT.: ;OPTION CODE FOLLOWS
INVAL
HRRE
IF SKIPGE
THEN ; ON SWITCH
IORM YSWITCH
ELSE ; OFF SWITCH
ANDM YSWITCH
FI
NEXT
OTHER.: ;--- START OF OTHERWISE CLAUSE ---
L XZHE,YDCSTP ; INSPECT ZHB HAS JUST BEEN CAUSED
LF() ZHEDLV(XZHE) ;CODE TO CLEAR DISPLAY ENTRY
OP (SETZM (XCB))
GENABS
LF(X2) ZHEFIX(XZHE)
L X1,X2
SETZM @YDCSTP
DEFIX
EXEC CAUSTD
NEXT
SUBTTL PBEND,PURGE,SEMIC
PBEND.: ;--- END OF PREFIXED BLOCK ---
;IF ANY PREFIX HAS AN EXPLICIT INNER, COMPILE A JUMP TO THE
;INNERMOST SUCH PREFIX, OTERWISE SET XCB TO SURROUNDING
;BLOCK ADDRESS.
;DEFINE FIXUP F+4 (ZCPIEA).
;UNDISPLAY, OUTPUT PROTOTYPE AND MAP(S), UNSTACK
EXEC CPEND
IF
SKIPE X2
THEN
LF() ZHBSBL(XZHE)
MOVN
OP (MOVE XCB,(XCB))
GENABS
FI
LF(X2) ZHEFIX(XZHE)
LI X1,4(X2)
DEFIX
LI X1,5(X2)
DEFIX
EXEC CAEB
NEXT
PURGE.: ;--- FLAG A COMPILATION ERROR, PURGE OPERAND STACK
;AND PARTIAL CODE TREES
L [RTSERR QDSCON,QSORCERROR] ;[41]
GENABS
BRANCH CGPU
SWEND.: ;--- END OF SWITCH DECLARATION
STACK YGAP
STACK YQREL
LI QRELPT
ST YGAP
ST YQREL
HLRZ X1,YCGSWC
DEFIX
HLRZ X1,YCGSWC
AOJ X1,
HRROS YTENT
UNSTK YQREL ; THIS FIXUP IN CODE
DEFIX
HRRZ YCGSWC
GENABS
MOVSI 2
GENABS ; 2,,0
L X2,YZHET
LF X1,ZHEDLV(X2)
HRLZ X1
GENABS ; -DLV,,0
L X2,YZHBXC
LF ,ZHBSZD(X2)
ADDI 3
GENABS ; 0,,ZPCSZD
SETZM YCGSWC
UNSTK YGAP
L YORZHB
ST YZHBXC
EXEC CAUS
SETZM @YDCSTP ;[132]
NEXT
LIT
RELOC 0
VAR
END