Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/ca.mac
There are 2 other files named ca.mac in the archive. Click here to see a list.
00100 SUBTTL Lars Enderin June 1973
00200
00300 Comment; ==== Module CA ====
00400
00500 Author: Lars Enderin
00600
00700 Version: 4A [6,13,17,30,40,41,132,136,140,144,176,321]
00800
00900 Purpose: Handles control symbols (i e neither operators nor
01000 operands)
01100
01200 Contents: Actions for BBLK, BPROG, etc. (symbol type SYMBT2)
01300
01400 Entry: CAEN
01500
01600 ;
01700 twoseg
01800 RELOC 400K
01900 search simmac,simmc2,simmcr,simrpa
02000 CTITLE CA
02100 sall
02200 macinit
02300
02400 ;--- External routines
02500
02600 IFN QDEBUG,<EXTERN YCADB,O2DB1,O2DB2,O2DB3
02700 >
02800 EXTERN CGAD,CGCA,CGCC,CGCO,CGIM,CGIM1,CGMO,CGMO1,CGVA,O2AF,O2SM
02900 EXTERN O2AB,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4
03000 EXTERN CARL,CGPU
03100 EXTERN O2EX,M2CO
03200 EXTERN O2LN1,O2LN2,O2LN3,O2LN4,O2LN5,O2LN6
03300 EXTERN O2AD,O2CF,O2DF,O2DFTE,O2GA,O2GF,O2GI,O2GR,O2GW,O2GWD,O2IV
03400 EXTERN CGLO,CGLO1,CGRD
03500
03600 ;--- External data
03700
03800 EXTERN QOPSTZ
03900 EXTERN YUNDEC,YRELLT,YRELST,YORFX,YQRELR,YQRELL,YQRELT
03950 EXTERN YCANTR,YCGSWC,YQREL,YCASM
04000 EXTERN YDCSTB,YTEXTI,YPROCI,YSIMUI,YSYSI,YSYSO,YSWCHA
04100 EXTERN YCALID,YCAMTC,YCAQND,YCAZMP,YCAZHE,YLXIAC
04200 EXTERN YELIN1,YELIN2 ;[40]
04300 EXTERN YBKST,YBKSTP,YCERFL,YDCSTO,YDCSTP,YDICTB,YEXPL,YEXPP
04400 EXTERN YFORSI,YGAP,YLINE,YMPSIZ,YCABKB
04500 EXTERN YOPSTB,YOPST,YOPSTP,YORZHB,YORZQU,YO2ZSD
04600 EXTERN YRDSTO,YRDSTP,YRELPT,YSTATM,YTENT,YZHET,YZHBXC
04700 EXTERN YRELCD,YSWRF
04800
04900 INTERN CACO,CADS,CADISP,CAEN,CADS,CAUD,CAUNDI,CAUS,CAUSTD,ERROR.
05000 INTERN CAPROT,CAUNPR ;[40]
00100 SUBTTL MACROS, OPDEFS
00200
00300 ;--- MACRO DEFINITIONS
00400 CGINIT
00500
00600 DEFINE $$$DO <GOTO FALSE>
00700 DEFINE $$$THEN <GOTO FALSE>
00800
00900 IFE QDEBUG,<DEFINE CHKOFS(F)<>
01000 >
01100 IFN QDEBUG,<
01200 DEFINE CHKOFS(F)<
01300 IRP F,<
01400 IFN <<WOFS>&777777-OFFSET(F)>,<
01500 CFAIL WRONG OFFSET: F
01600 >>>
01700 OPDEF RH [POINT 18,0,35]
01800 RH==RH
01900 DEFINE RIGHTHALF(A)<
02000 IFN <RH-<<$'A>&<777777B17>>>,
02100 <CFAIL A IS NOT IN RH>>
02200 >
02300 DEFINE NEXTWORD<WOFS==WOFS+1>
02400
02500 ;--- OPDEF'S
02600
02700 OPDEF NEXT [POPJ XPDP,]
02800 OPDEF UNDISP [PUSHJ XPDP,CAUD]
00100 SUBTTL TEMPORARY DEFINITIONS
00200
00300 DEFINE D(X) <
00400 X=..N
00500 ..N=..N+1
00600 >
00700
00800 ;MISCELLANEOUS:
00900
01000 ..N=100
01100 D EILSYM
01200 D EDCOFL
00100 SUBTTL CAEB
00200
00300 COMMENT; === ROUTINE CAEB ===
00400 PURPOSE: CALLED AT END OF UNREDUCED SUBBLOCK, CLASS,
00500 PROCEDURE OR PREFIXED BLOCK.
00600 OUTPUTS PROTOTYPE AND VARIABLE MAP (FOR GARBAGE COLLECTOR
00700 AND ENTRY INTO REDUCED SUBBLOCK) FOR THE BLOCK AND ANY
00800 ENCLOSED, REDUCED SUBBLOCKS. UNDISPLAYS THE ZQU RECORDS.
00900 REMOVES THE BLOCK FROM DSTACK EXCEPT WHEN IT IS A CLASS BLOCK.
01000 OUTPUTS LINE AND SYMBOL TABLE ENTRIES FOR BLOCK
01100 ENTRY: EXEC CAEB
01200 EXIT: RETURN
01300 USES: CADS,CAMM,CAUNDI,CAUD,O2GA,O2GF,O2GP,O2GR,O2LN4,CAUS,CAFQX2
01400 INPUT: XZHE POINTS TO ZHE OR ZHB FOR TERMINATING BLOCK
01500 ;
01600
01700 XFIX=X5
01800
01900
02000 CAEB: PROC
02100 SAVE <X2,X3,X4,X5,X6,XP1>
02200 EXEC O2LN4
02300 L YRELST
02400 ST YCASM ; SYMBOL TABLE START
02500 ; RESET YZHBXCB
02600 IF CAME XZHE,YZHBXC
02700 THEN
02800 HRRZ X1,YBKSTP
02900 LOOP SOS X1
03000 AS
03100 HRRZ X2,(X1)
03200 CAIG X1,YBKST
03300 GOTO FALSE
03400 WHENNOT X2,ZHB
03500 GOTO TRUE
03600 IFEQF X2,ZHETYP,QINSPE
03700 GOTO TRUE
03800 SA
03900 ST X2,YZHBXC
04000 FI
04100 ST XZHE,YCAZHE
04200 SETZM XP1
04300 IF
04400 LF() ZHETYP(XZHE)
04500 CAIE QPROCB
04600 THEN ;UNDISPLAY PROC QUANTS
04700 ASSERT< WHENNOT XZHE,ZHB
04800 RFAIL PROCEDURE ZHE FOUND NOT ZHB
04900 >
05000 LF (X1)ZHBZQU(XZHE)
05100 LF (X1)ZQUTYP(X1)
05200 SF (X1)ZPCTYP(,XP1-OFFSET(ZPCTYP))
05300 LF(XZHE)ZHBZE(XZHE)
05400 UNDISPLAY
05500 EXCH XZHE,YCAZHE
05600 UNDISPLAY
05700 EXCH XZHE,YCAZHE
05800 ELSE
05900 EXEC CAUNDI ;UNDISPLAY FOLLOWING ZHBZHB CHAIN
06000 EXEC CAPROT ;[40]
06100 FI
06200 LI X6,YCAZMP ;MAKE A MAP
06300 EXEC CAMM
06400 STACK YQRELR
06500 ; OUTPUT ZSM?
06600 LI X3,QRELID
06700 EXCH X3,YQRELR
06800 LI QRELST
06900 ST YQRELT
07000 IF LF ,ZHETYP(XZHE)
07100 CAIN QPROCB
07200 GOTO TRUE
07300 CAIE QCLASB
07400 THEN ; OUTPUT ZSMRNM
07500 EXCH XZHE,YCAZHE
07600 LF X2,ZHBZQU(XZHE)
07700 IF IFOFF ZQUGLOB(X2)
07800 THEN ; PRECEDE SYMBOL TABLE WITH LINE NUMBER TABLE POINTER
07900 LI QRELLT
08000 ST YQRELR
08100 L YRELLT
08200 SOS
08300 GENREL
08400 LI QRELID
08500 ST YQRELR
08600 FI
08700 LF ,ZQULID(X2)
08800 GENREL
08900 LF ,ZQULID(X2)
09000 AOS YQRELR ; ASSUMES QRELI2=QRELID+1
09100 GENREL
09200 EXCH XZHE,YCAZHE
09300 FI
09400 L YRELST
09500 ST YCASM
09600 LI QRELST
09700 ST YQRELR
09800 ST YGAP ;[13] TO PREPARE FOR USE OF GENABS
09900 HLRZ YCAZMP ; SYMBOL TABLE(ZSD) POINTER
10000 LF X2,ZHETYP(XZHE)
10100 SF X2,ZSMTYP(X0)
10200
10300 ;[13] OUTPUT ZERO AND NOT THE BASE ADDRESS OF THE SYMBOL TABLE
10400 ; IF ZSD-POINTER = 0
10500 IF
10600 TRNE X0,-1
10700 THEN
10800 GENABS
10900 ELSE
11000 GENREL
11100 FI
11200
11300 LI QRELST
11400 ST YQRELL
11500 HRRZ X2,YCAQND
11600 SETZ X1,
11700 IF IFOFF YSWD
11800 THEN ; OUTPUT POINTERS TO SYMBOL TABLE
11900 WHILE CAML X2,YDCSTP
12000 DO ; GT A POINTER
12100 LF ,ZMPZSD(X2)
12200 IF SKIPE X1
12300 THEN ;ODD POINTER
12400 HRL X1,
12500 ELSE ; OUTPUT TWO POINTERS
12600 ADD X1
12700 GENREL
12800 SETZ X1,
12900 FI
13000 STEP X2,ZMP
13100 OD
13200 FI
13300 IF SKIPN X1
13400 THEN ;OUTPUT LAST POINTER
13500 SETZM YQRELR
13600 L X1
13700 GENREL
13800 SETZM YQRELL
13900 ELSE
14000 SETZM YQRELR
14100 SETZM YQRELL
14200 SETZ
14300 GENREL
14400 FI
14500 LI QRELPT
14600 ST YQRELT
14700 EXCH X3,YQRELR
14800 LI X5,(X6)
14900 L X6,YRELPT ;REMEMBER WHERE IN PROTOTYPE SECTION
15000 L X2,YCAQND
15100 ;--- OUTPUT MAPS TO PROTOTYPE STREAM ---
15200 LI QRELPT ; OUTPUT PROTOTYPES TO PROTOTYPE STREAM
15300 ST YQRELT
15400 ST YGAP
15500 ST YQRELR
15600 LOOP
15700 HRLI X5,-ZMP%S
15800 ASSERT<RIGHTHALF(ZMPZMP)>
15900 ADDM X6,OFFSET(ZMPZMP)(X2)
16000 IF CAMN X6,YRELPT
16100 THEN ; NOT FIRST MAP IN VECTOR
16200 L (X5)
16300 GENREL
16400 ELSE
16500 SETZM (X5)
16600 SUB X5,[1,,1]
16700 FI
16800 WHILE INCR X5,TRUE
16900 DO
17000 L (X5)
17100 GENABS
17200 OD
17300 L X5,X2
17400 STEP X2,ZMP
17500 AS
17600 ASSERT<
17700 CAMLE X2,YDCSTP
17800 GOTO FALSE
17900 WHENNOT X2,ZMP
18000 RFAIL ZMP EXPECTED AT X2
18100 WHENNOT X2,ZMP
18200 GOTO FALSE
18300 >
18400 CAMG X2,YDCSTP
18500 GOTO TRUE
18600 SA
18700
18800 UNSTK YQRELR
18900 LF(XFIX)ZHEFIX(XZHE)
19000
19100 IF ;--CLASS OR PREFIXED BLOCK --
19200 LF(X4) ZHETYP(XZHE)
19300 CAIE X4,QCLASB
19400 CAIN X4,QPBLOCK
19500 GOTO TRUE
19600 THEN
19700 ;OUTPUT ANY VIRTUAL DESCRIPTORS (STARTING WITH THE HIGHEST INDEX)
19800 LF(X3) ZHBVRT(XZHE) ;NUMBER OF VIRTUALS
19900 WHILE
20000 SOJGE X3,TRUE ;VIRTUAL INDEXES START AT 0
20100 DO
20200 EXEC CAEBVM ;FIND THE MATCH IF ANY
20300 IF
20400 SKIPN X2,YCAMTC
20500 THEN ;WE HAD A MATCH
20600 LF() ZQUIND(X2) ;LABEL,SWITCH,PROC: FIXUP IN ZQUIND
20700 OP (HRLZI XWAC1,)
20800 GENFIX
20900 ELSE
21000 L [RTSERR QVIRTE]
21100 GENABS
21200 FI
21300 STEP X2,ZQU
21400 OD
21500
21600
21700 ;NOTE THAT THE PROTOTYPE IS DEVELOPED ONE WORD AT A TIME IN X0
21800 ;AND OUTPUT. THE OFFSET IS USED TO MAKE THE EFFECTIVE ADDRESS
21900 ;ZERO, AS IN ZCPZCP(,WOFS) (CHECK GENERATED CODE IN OCTAL).
22000
22100 WOFS==-4
22200 CHKOFS <ZCPZCP>
22300 LF(X1) ZHBZHB(XZHE)
22400 IF
22500 JUMPN X1,TRUE
22600 THEN
22700 LF X1,ZHBZQU(X1)
22800 LF(X1) ZQUIND(X1) ;FIXUP OF PREFIX MUST BE ACCESSED THROUGH ZQU
22900 WSF(X1) ZCPZCP(,-WOFS) ;(OR ZERO) TO X0
23000 GENFIX
23100 ELSE
23200 SETZ
23300 GENABS
23400 FI
23500 NEXTWORD
23600 CHKOFS <ZCPSTA,ZCPKDP>
23700 LI X1,3(XFIX) ;FIXUP FOR 'STATEMENTS'
23800 IFON ZHBKDP(XZHE)
23900 SETONA ZCPKDP(X1)
24000 L X1
24100 GENFIX
24200
24300 NEXTWORD
24400 CHKOFS <ZCPIEA>
24500 LI 4(XFIX)
24600 GENFIX
24700
24800 NEXTWORD
24900 CHKOFS <ZCPSBL,ZCPPRL>
25000 SETZ ;PREFIX LEVEL
25100 L X1,XZHE
25200 LOOP
25300 LF(X1) ZHBZHB(X1)
25400 AS
25500 JUMPE X1,FALSE
25600 LF X3,ZHBNRP(X1)
25700 JUMPE X3,.+2
25800 SETONA ZPCPAR(XP1)
25900 AOJA TRUE
26000 SA
26100 LF(X1) ZHBSBL(XZHE) ;
26200 MOVN X1,X1
26300 SF(X1) ZCPSBL(,-WOFS)
26400 GENABS
26500 FI;--- CLASS OR PREFIXED BLOCK ---
26600 ;--- COMMON PART (ZPR) ---
26700
26800 CAIN X4,QPROCB
26900 L XZHE,YCAZHE ; RESET TO ZHE FOR PROCEDURE
27000 L X1,XFIX
27100 LI X2,QRELPT
27200 EXCH X2,YQREL
27300 DEFIX ;DEFINE FIXUP FOR THE PROTOTYPE
27400
27500 EXCH X2,YQREL
27600 WOFS==0
27700 CHKOFS <ZPRBLE,ZPRMAP>
27800 SF(X6) ZPRMAP(,-WOFS) ;LINK TO MAP
27900 LF(X1) ZHELEN(XZHE)
28000 SF(X1) ZPRBLE(,-WOFS)
28100 EXCH X2,YQRELR
28200 GENREL
28300 EXCH X2,YQRELR ; RESTORE QRELCN
28400
28500 NEXTWORD
28600 CHKOFS <ZPREBL,ZPRSYM>
28700 LF(X1) ZHEDLV(XZHE)
28800 SF(X1) ZPREBL(,-WOFS)
28900 LI X2,QRELST
29000 EXCH X2,YQRELR
29100 HRR YCASM
29200 GENREL
29300 EXCH X2,YQRELR
29400 IF ;NOT A SUBBLOCK
29500 CAIN X4,QUBLOCK
29600 THEN ;TREAT ZPC PART
29700 NEXTWORD
29800 CHKOFS <ZPCNRP,ZPCDLE>
29900 LF() ZHBSZD(XZHE)
30000 ADDI 2 ; ACCOUNT FOR OVERHEAD
30100 ASSERT <RIGHTHALF ZPCDLE>
30200 LF(X1) ZHBNRP(XZHE)
30300 JUMPE X1,.+2
30400 SETONA ZPCPAR(XP1)
30500 SF(X1) ZPCNRP(,-WOFS)
30600 GENABS
30700
30800 NEXTWORD
30900 CHKOFS <ZPCDEC>
31000 LI 2(XFIX)
31100 HLL XP1 ; PARAMETER PRESENT BIT IN CLASS PROTOTYPE
31200 GENFIX
31300
31400 ;--- FORMAL DESCRIPTORS ---
31500
31600 EXEC CAFQX2
31700 WHILE
31800 RECTYPE(X2) IS ZQU
31900 DO
32000 IF ;A PARAMETER
32100 LF(X1) ZQUMOD(X2)
32200 CAIGE X1,QVIRTUAL
32300 CAIG X1,QDECLARED
32400 THEN ;FORM A DESCRIPTOR IN X3
32500 SETZ X3,
32600 ;TYPE, MODE,KIND
32700 LF() ZQUTMK(X2)
32800 SF() ZFPTMK(,X3)
32900 ASSERT <RIGHTHALF ZFPOFS>
33000 LF() ZQUIND(X2)
33100 HLL X3
33200 GENABS
33300 IF ;TYPE REF (ASSUME LEFT HALF)
33400 LF() ZTDTYP(,X3)
33500 CAIE QREF
33600 THEN
33700 LF(X1) ZQUZQU(X2) ;[17] ZHB of qualif. class
33800 LF(X3) ZHBZQU(X2) ;[17] Corresp. ZQU
33900 IF ;[17] System class
34000 IFOFF ZQUSYS(X3)
34100 THEN ;Use 18 bits for fixup
34200 HRRZ OFFSET(ZHEFIX)(X1)
34300 ELSE ;Use normal field
34400 LF() ZHEFIX(X1)
34500 FI ;[17]
34600 GENFIX
34700 FI
34800 FI
34900 STEP X2,ZQU
35000 OD;
35100 FI;
35200
35300 ;--- PROTOTYPE FINISHED ---
35400
35500 LI QRELCD ;RESTORE DEFAULT LOCATION COUNTER
35600 ST YGAP
35700 ST YQRELT
35800 L X3,YDCSTP ;SAVE YDCSTP IN CASE OF A CLASS BLOCK
35900 EXEC CAUS
36000 L X1,YCAZHE
36100 LF() ZHETYP(X1)
36200 IF CAIE QCLASB
36300 THEN
36400 ST X3,YDCSTP
36500 ELSE
36600 IF CAIE QPROCB
36700 THEN
36800 ASSERT< WHENNOT X1,ZHB
36900 RFAIL ZHB EXPECTED CAEB
37000 >
37100 LF X3,ZHBZE(X1)
37200 ZF ZHBZE(X1) ; RESET ZHE POINTER
37300 ST X3,YDCSTP
37400 FI
37500 FI
37600 SETZM @YDCSTP
37700 RETURN
37800 EPROC ;--- CAEB ---
00100 COMMENT; ===ROUTINE CAEBVM===
00200 PURPOSE: TO FIND THE LAST VIRTUAL MATCH CORRESPONDING TO
00300 VIRTUAL INDEX (X3) IN A CLASS WITH POSSIBLE PREFIX
00400 CHAIN
00500 ENTRY: EXEC CAEBVM
00600 CALLED RECURSIVELY BY ITSELF THROUGH THE POINT CAEBV.
00700 EXIT: RETURN
00800 ;
00900
01000 CAEBVM: PROC
01100 SETZM YCAMTC
01200 SETZM YCALID
01300 CAEBV.: STACK XZHE
01400 LF(XZHE)ZHBZHB(XZHE) ;PREFIX?
01500 JUMPE XZHE,.+2
01600 EXEC CAEBV. ;FIND NEXT PREFIX
01700 UNSTK XZHE
01800 STEP XZHE,ZHB,X2 ;X2 :- NEXT ZQU
01900 WHILE
02000 RECTYPE(X2) IS ZQU
02100 DO
02200 IF
02300 IFON ZQUDD(X2) ;[140]
02400 GOTO FALSE ;[140]
02500 LF() ZQUMOD(X2)
02600 CAIE QVIRTUAL
02700 THEN ;SPEC FOR THIS VIRTUAL OR MATCH FOR ANOTHER?
02800 LF() ZQUNSB(X2) ;A MATCH HAS ZQUNSB > 0
02900 IF
03000 JUMPE TRUE
03100 THEN ;(SPEC)
03200 LF() ZQUIND(X2)
03300 IF
03400 CAIE (X3)
03500 THEN ;SPEC FOR THIS VIRTUAL FOUND
03600 LF() ZQULID(X2)
03700 ST YCALID
03800 ELSE ;[140]
03900 LF() ZQULID(X2)
04000 CAMN YCALID
04100 SETZM YCALID ;Disable further match when redeclared
04200 FI
04300 ELSE ;MATCH?
04400 LF() ZQULID(X2)
04500 IF
04600 CAME YCALID
04700 THEN
04800 ST X2,YCAMTC
04900 FI
05000 FI
05100 FI
05200 STEP X2,ZQU
05300 OD;
05400 RETURN
05500 EPROC
00100 SUBTTL CA DISPATCH TABLE
00200
00300 CAEN: L XZHE,YZHET
00400 GOTO @.-SYMBL2(XCUR)
00500 DEFINE X(A,B,C,D) <
00600 IFL <SYMBL2-B>, <
00700 IFG <SYMBL3-B>, <
00800 A'.>>>
00900 SYMB(6,0,X)
01000
01100 ILSYM.: RFAIL ILLEGAL SYMBOL (CA)
01200 NEXT
00100 SUBTTL CAMM (MAKE MAP OF BLOCK)
00200
00300 COMMENT; === ROUTINE CAMM ===
00400 PURPOSE: CONVERT A SEQUENCE OF ZQU RECORDS TO A ZMP RECORD
00500 (GARBAGE COLLECTOR MAP).
00600 Note that text variables are assumed to follow
00700 "other" variables. The count of text variables
00800 is included in the count for other variables
00900 to simplify initialisation of (reduced) subblocks.
01000 For the benefit of the garbage collector, text variables
01100 are also accounted for separately. The count, in each
01200 instance, is negated and represents the number of words
01300 rather than the number of variables. The format of each
01400 descriptor word is suitable for loop counting.
01500 INPUT: XZHE POINTS TO ZHE OR ZHB OF THE ZQU LIST
01600 X6 POINTS TO WHERE THE MAP IS PUT
01700 ENTRY: EXEC CAMM
01800 EXIT: RETURN
01900 ;
02000
02100 CAMM: PROC
02200 SAVE <X2,X3,X4,X5>
02300 XMP=X2 ;BASE OF ZMP RECORD IN REGISTERS
02400 XOV=X3 ;'OTHER' VARIABLES
02500 XRV=X4 ;REF AND ARRAY
02600 XTX=X5 ;TEXT
02700 SETZB X2,X3
02800 IF CAMN XZHE,YCAZHE ; PROC ZHE?
02900 GOTO FALSE
03000 LF ,ZHETYP(XZHE)
03100 CAIE QPROCB
03200 GOTO FALSE
03300 IFOFF YSWD
03400 THEN
03500 ; OUTPUT PROC PARMS
03600 L X3,YCAZHE
03700 HRLI X3,ZHB%S(X3)
03800 FI
03900 EXEC CAFQX2 ;FIRST ZQU TO X2
04000 HLL X2,X3
04100 IFON YSWD
04200 EXEC O2SM ; OUTPUT SYMBOLS AND RETURN ZSD POINTER IN YO2ZSD
04300 SETZB XOV,XRV
04400 SETZ XTX,
04500 WHILE
04600 RECTYPE(X2) IS ZQU
04700 DO
04800 IFNEQF X2,ZQUMOD,QDECLARED ;DECLARED VARIABLE?
04900 GOTO L1
05000 LF(X1) ZQUIND(X2)
05100 LF() ZQUKND(X2) ;KIND
05200 CAIN QARRAY
05300 GOTO CAMM.R
05400 CAIE QSIMPLE
05500 GOTO L1
05600 ;---SIMPLE VARIABLE, CHECK TYPE ---
05700 LF() ZQUTYP(X2)
05800 CAIN QREF
05900 GOTO CAMM.R
06000 CAIN QTEXT
06100 GOTO CAMM.T
06200 CAIN QLABEL
06300 GOTO L1
06400 ;-- SIMPLE, 'OTHER' VARIABLE ---
06500 JUMPN XOV,.+2
06600 SF(X1) ZMPDOV(,XMP)
06700 SUB XOV,[1,,0] ;NEGATIVE COUNT IN LEFT HALF
06800 CAIN QLREAL
06900 SUB XOV,[1,,0] ; TWO WORDS FOR LONG REAL
07000 GOTO L1
07100
07200 CAMM.R: ;--- REF OR ARRAY ---
07300 JUMPN XRV,.+2
07400 SF(X1) ZMPDRV(,XMP)
07500 SUB XRV,[1,,0] ;NEGATIVE COUNT IN LEFT HALF
07600 GOTO L1
07700
07800 CAMM.T: ;--- TEXT VARIABLE ---
07900 JUMPN XTX,.+2
08000 SF(X1) ZMPDTX(,XMP)
08100 SUB XTX,[2,,0] ;TEXT VARIABLE HAS TWO WORDS
08200 L1(): STEP X2,ZQU
08300 OD;
08400 ; SET YCAQND
08500 WHILE LF X1,ZDETYP(X2)
08600 SKIPN X1
08700 DO
08800 XCT CAMM.S(X1) ; STEP RECORD
08900 OD
09000 IF SKIPE XOV
09100 THEN ;NO OTHER VARIABLES
09200 L XOV,XTX
09300 ELSE
09400 HLLZ XTX
09500 ADD XOV,
09600 FI
09700 ST X2,YCAQND
09800 HLLZ XMP,YO2ZSD
09900 STD XMP,(X6)
10000 STD XMP+2,2(X6)
10100 CAMM.O: RETURN
10200 ; !!! ZHE%V=1,ZHB%V=2,ZQU%V=4
10300 EPROC
10400 CAMM.S: RFAIL CAMMS
10500 STEP X2,ZHE
10600 STEP X2,ZHB
10700 RFAIL CAMMS
10800 STEP X2,ZQU
00100 SUBTTL CACO
00200
00300 COMMENT; === ROUTINE CACO ===
00400 PURPOSE: COPIES ZHB OF THE CLASS THAT IS POINTED TO BY ZHBZHB(XZHE),
00500 THEN COPIES ITS ZQU LIST. THE SAME IS DONE FOR EACH
00600 PREFIX. THE ZHBZHB CHAIN IS UPDATED TO POINT TO THE COPIED
00700 CLASS ETC. ZQUZHE ENTRIES ARE CHANGED TO POINT TO
00800 THE CONNECTION ZHB.
00900 ENTRY: EXEC CACO
01000 EXIT: RETURN
01100 USES: CADISP,M2CO,O2AB,O2LN6,CAUSTD
01200 ;
01300
01400
01500 CACO: PROC
01600 SAVE <X2,X3,X4,X5,X6>
01700 SETZ X6,
01800 ASSERT<WHENNOT XZHE,ZHB
01900 RFAIL CACO PARAMETER ERROR
02000 >
02100 L X3,XZHE
02200 L X4,YDCSTP
02300 CAML X4,YDCSTO
02400 EXEC M2CO ; MORE CORE NEEDED
02500 LI X1,-1(X4)
02600 LF ,ZHBZHB(X3)
02700 CAML YDCSTB
02800 CAML YDCSTP
02900 BRANCH O2AB ; NO RECOVERY IF INSPECTED CLASS UNKNOWN
03000 WHILE
03100 LF(X5) ZHBZHB(X3)
03200 JUMPN X5,TRUE
03300 DO
03400 ASSERT< WHENNOT X5,ZHB
03500 RFAIL ZHBZHB LINKS ERROR CACO
03600 >
03700 STEP X1,ZHB
03800 STEP X5,ZHB,X2
03900 ;/COPY ZHB/;
04000 HRLI (X5)
04100 HRRI (X4)
04200 BLT (X1)
04300 SKIPE X6
04400 SF X4,ZHBZHB(X6) ;INSERT PREFIX OF COPY
04500 L X6,X4
04600 STEP X4,ZHB
04700 CAML X4,YDCSTO
04800 EXEC M2CO
04900 WHILE
05000 RECTYPE(X2) IS ZQU
05100 DO
05200 STEP X1,ZQU
05300 ;/COPY ZQU/;
05400 HRLI (X2)
05500 HRRI (X4)
05600 BLT (X1)
05700 SF(XZHE)ZQUZHE(X4) ;NEW ZQUZHE
05800 SETON ZQUIS(X4)
05900 LI X4,1(X1)
06000 STEP X2,ZQU
06100 CAML X4,YDCSTO
06200 EXEC M2CO
06300 OD
06400 L X3,X5
06500 OD
06600 L YDCSTP
06700 CAMN X4
06800 SETZ
06900 SF ,ZHBZHB(XZHE)
07000 IFON YSWI
07100 EXEC O2LN6
07200 SETZM (X4)
07300 EXEC CADISP ;DISPLAY PREFIXES, THEN CLASS, THEN CONNECTION
07400 ASSERT< CAML X4,YDCSTO
07500 RFAIL DECL. STACK OVERFLOW
07600 >
07700 ST X4,YDCSTP
07800 EXEC CAUSTD
07900 RETURN
08000 EPROC
00100 SUBTTL CAPL,CAUS
00200
00300 COMMENT; === ROUTINE CAPL ===
00400 PURPOSE: COMPUTE PREFIX LEVEL OF CLASS TO WHOSE ZHB RECORD XZHE POINTS,
00500 AND COMPILE: MOVEI XSAC,prefix level
00600 ENTRY: EXEC CAPL
00700 NORMAL EXIT: RETURN
00800 INPUT: XZHE, POINTS TO ZHB OF CLASS
00900 USED ROUTINE: O2GA
01000 ;
01100 CAPL: PROC
01200 SETZ ;PREFIX LEVEL TO X0
01300 L X1,XZHE
01400 LOOP
01500 LF(X1) ZHBZHB(X1)
01600 AS
01700 JUMPE X1,FALSE
01800 AOJA TRUE
01900 SA
02000 OP (MOVEI XSAC,)
02100 GENABS
02200 RETURN
02300 EPROC
02400
02500
02600 COMMENT; === ROUTINE CAUS ===
02700
02800 PURPOSE: STACK DOWN BLOCK STACK, DECLARATION STACK
02900 AND REDECLARATION STACK.
03000 UPDATE XZHE AND YZHET.
03100 CALL: EXEC CAUS
03200 EXIT: RETURN
03300 ;
03400
03500 CAUS: PROC
03600 L X1,YBKSTP ;STACK DOWN BLOCK STACK
03700 POP X1,X0
03800 HRRZM YDCSTP
03900 HLRZM YRDSTP
04000 HRRZ (X1)
04100 ST YZHET
04200 ST XZHE
04300 ST X1,YBKSTP
04400 RETURN
04500 EPROC
00100 SUBTTL CARDX3,CAFQX2
00200
00300 ;--- SMALL AUXILIARY ROUTINES ---
00400
00500 CARDX3: ;--- FORMS REDECLARATION STACK POINTER IN X3 ---
00600 HRRZ X3,YRDSTP
00700 SUB X3,YRDSTO
00800 HRL X3,X3
00900 HRR X3,YRDSTP
01000 RETURN
01100
01200 CAFQX2: ;--- MAKES X2 POINT TO FIRST ZQU RECORD ---
01300 STEP XZHE,ZHE,X2
01400 WHEN XZHE,ZHB
01500 STEP XZHE,ZHB,X2
01600 RETURN
01700
00100 SUBTTL CADS (DISPLAY)
00200
00300 COMMENT; === ROUTINE CADS ===
00400 PURPOSE: DISPLAY ZQU LIST POINTED TO BY XZHE INTO THE DICTIONARY,
00500 PUSHING OLD DECLARATIONS INTO REDECLARATION STACK.
00600 ENTRY: EXEC CADS
00700 EXIT: RETURN
00800 ;
00900
01000 CADS: PROC
01100 SAVE <X2,X3>
01200 IFN QDEBUG,<
01300 IF IFOFF SCADB5
01400 THEN
01500 EXEC O2DB1,<<[020000,,0]>> ; NEW LINE ON DEBUG FILE
01600 HRL XZHE
01700 EXEC O2DB3,<<[610000,,'DIS']>,X0>
01800 FI
01900 >
02000 EXEC CAFQX2 ;STEP X2 TO ZQU RECORD
02100 EXEC CARDX3 ;FORM REDECL STACK POINTER IN X3
02200
02300 WHILE
02400 RECTYPE(X2) IS ZQU
02500 DO
02600 LF(X1) ZQULID(X2)
02700 JUMPE X1,CADS.2
02800 IFON ZQUIVA(X2) ;[40]
02900 GOTO CADS.2 ;DONT DISPLAY IF INVISIBLE[40]
03000 IFN QDEBUG,<
03100 IF IFOFF SCADB5
03200 THEN ; DEBUG OUTPUT
03300 HRLI X1,300000
03400 EXEC O2DB2,<X1>
03500 HRRZ X1,X1
03600 FI
03700 >
03800 WLF() ZDCZDC(X1,YDICTB)
03900 JUMPE CADS.1
04000 PUSH X3, ;SAVE OLD DECL
04100 SF(X3) ZDCZDC(X1,YDICTB) ;AND REMEMBER WHERE.
04200 CADS.1: IF ;[136]
04300 IFON ZQUDD(X2) ;[136]
04400 THEN ;[136]
04500 SF(X2) ZDCZQU(X1,YDICTB) ;STORE NEW ZQU POINTER
04600 ELSE ;[136]
04700 SETF YUNDEC,ZDCZQU(X1,YDICTB) ;[136]
04800 FI ;[136]
04900 CADS.2: STEP X2,ZQU
05000 OD;
05100 ST X3,YRDSTP
05200 RETURN
05300 EPROC
00100 SUBTTL CAUD (UNDISPLAY)
00200
00300 COMMENT; === ROUTINE CAUD ===
00400 PURPOSE: UNDISPLAY ZQU LIST STARTED BY ZHE OR ZHB RECORD POINTED TO
00500 BY XZHE, RESTORING REDECLARED QUANTITIES.
00600 ENTRY: EXEC CAUD
00700 EXIT: RETURN
00800 ;
00900
01000 CAUD: PROC
01100 SAVE X2
01200 IFN QDEBUG,<
01300 IF IFOFF SCADB5
01400 THEN
01500 EXEC O2DB1,<<[020000,,0]>> ; NEW LINE ON DEBUG FILE
01600 HRL XZHE
01700 EXEC O2DB3,<<[610000,,'UDS']>,X0>
01800 FI
01900 >
02000 EXEC CAFQX2 ;GET FIRST ZQU TO X2
02100
02200 WHILE
02300 RECTYPE(X2) IS ZQU
02400 DO
02500 LF(X1) ZQULID(X2)
02600 IF
02700 IFOFF ZQUIVA(X2) ;[40] Not displayed if invisible
02800 SKIPN X1
02900 THEN
03000 IFN QDEBUG,<
03100 IF IFOFF SCADB5
03200 THEN ; DEBUG OUTPUT
03300 HRLI X1,300000
03400 EXEC O2DB2,<X1>
03500 HRRZ X1,X1
03600 FI
03700 >
03800 LF() ZDCZDC(X1,YDICTB) ;ANY REDECLARATION FOR THIS QUANTITY?
03900 JUMPE .+2 ;IF NOT, STORE ZERO IN DICTIONARY,
04000 L @ ;OTHERWISE RESTORE OLD DECLARATION
04100 WSF() ZDCZDC(X1,YDICTB)
04200 FI
04300 STEP X2,ZQU
04400 OD;
04500 RETURN
04600 EPROC
00100 SUBTTL CADISP,CAUNDI
00200
00300 CADISP: PROC ;DISPLAY PREFIXES, THEN THE CLASS OR PREFIXED BLOCK
00400 STACK XZHE
00500 LF(XZHE)ZHBZHB(XZHE)
00600 JUMPE XZHE,.+2
00700 EXEC CADISP ;RECURSIVE CALL
00800 UNSTK XZHE
00900 DISPLAY
01000 RETURN
01100 EPROC
01200
01300
01400 CAUNDI: PROC ;UNDISPLAY A BLOCK AND POSSIBLE PREFIXES
01500 ;WORKS ALSO FOR CONNECTION BLOCK
01600 SAVE <XZHE>
01700 IF
01800 RECTYPE(XZHE) IS ZHE
01900 THEN
02000 UNDISPLAY
02100 ELSE
02200 LOOP
02300 UNDISPLAY
02400 LF(XZHE)ZHBZHB(XZHE)
02500 AS
02600 JUMPN XZHE,TRUE
02700 SA
02800 FI
02900 RETURN
03000 EPROC
03100 CAUSTD: PROC ; UPDATE ZHBSTD ON ENTRY AND EXIT TO
03200 ; FOR STATMT, INSPECTION AND UNREDUCED SUBBLOCK
03300 SAVE <X2,X3>
03400 L X2,YZHET
03500 L X3,YZHBXC
03600 ASSERT< WHENNOT X3,ZHB
03700 RFAIL NOT ZHB AT YZHBXCB
03800 >
03900 LF X1,ZHEDLV(X2) ; NEW TOP
04000 MOVN X1,X1
04100 ADDI X1,1
04200 LF ,ZHBSTD(X3)
04300 LF X2,ZHBSZD(X3)
04400 CAIG X2,(X1)
04500 SF X1,ZHBSZD(X3)
04600 SF X1,ZHBSTD(X3)
04700 CAIL X1,QMAXDIS
04800 ERROR2 50,DISPLAY SIZE OVERFLOW
04900 RETURN
05000 EPROC
00100 SUBTTL CAUNPR [40]
00200
00300
00400 COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
00500
00600 FUNCTION: Make all protected attributes accessible and hide
00700 hidden attributes. If FLAG is zero then check
00800 own HIDDEN specifications.
00900
01000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
01100
01200
01300 CAUNPR: PROC <FLAG>
01400 SAVE <X1,X2,X3,X4,X5,XZHE>
01500 EXEC CAUNP1
01600 EXEC CAUNP2
01700 WHEN X2,ZQU
01800 SKIPE FLAG
01900 SKIPA
02000 EXEC CAUNP3
02100 RETURN
02200 EPROC
02300
02400 CAUNP1: PROC
02500 SAVE XZHE
02600 LF XZHE,ZHBZHB(XZHE)
02700 IF SKIPN XZHE
02800 THEN
02900 EXEC CAUNP1
03000 EXEC CAUNP2
03100 WHEN X2,ZQU
03200 EXEC CAUNP4
03300 FI
03400 RETURN
03500 EPROC
03600
03700
03800 CAUNP2: PROC
03900 STEP XZHE,ZHB,X2
04000 WHILE
04100 WHENNOT X2,ZQU
04200 DO
04300 IF IFOFF ZQUIVA(X2)
04400 THEN
04500 IFOFF ZQUPTD(X2)
04600 RETURN ;X2 POINTS TO FIRST HIDDEN SPEC
04700 SETOFF ZQUIVA(X2)
04800 FI
04900 STEP X2,ZQU
05000 OD
05100 RETURN
05200 EPROC
05300
05400
05500 CAUNP3: PROC
05600 LI X5,0 ;[140]
05700 WHILE
05800 EXEC CAUNP5
05900 SKIPN X3
06000 DO
06100 IF JUMPE X4,FALSE ;[140]
06200 IFON ZQUUSE(X4) ;[140]
06300 THEN
06400 SETON ZQUUSE(X4)
06500 IF
06600 IFON ZQUNOT(X2)
06700 ;[140] GOTO [JUMPE X4,TRUE
06800 ;[140] GOTO FALSE]
06900 ;[140] JUMPN X4,TRUE
07000 THEN
07100 IFOFF ZQUPTD(X3)
07200 EXEC CAE421
07300 FI ;[140]
07400 FI
07500 OD
07600 LOOP
07700 IFOFF ZQUUSE(X2)
07800 EXEC CAE422
07900 SETOFF ZQUUSE(X2)
08000 STEP X2,ZQU
08100 AS
08200 WHEN X2,ZQU
08300 GOTO TRUE
08400 SA
08500 RETURN
08600 EPROC
08700
08800
08900 CAUNP4: PROC
09000 LI X5,0 ;[140]
09100 WHILE
09200 EXEC CAUNP5
09300 SKIPN X3
09400 DO
09500 ;[140]
09600 IF IFON ZQUNOT(X2)
09700 THEN ;HIDDEN
09800 IF JUMPE X4,FALSE
09900 IFON ZQUUSE(X4)
10000 THEN
10100 IF IFOFF ZQUPTD(X3)
10200 THEN
10300 SETON ZQUIVA(X3)
10400 FI
10500 IF IFNEQF X3,ZQUMOD,QVIRTUAL
10600 GOTO TRUE
10700 IFNEQF X3,ZQUNSB,0
10800 THEN ;Not virtual match
10900 SETON ZQUUSE(X4)
11000 FI
11100 FI
11200 ELSE ;NOT HIDDEN
11300 IF SKIPE X4
11400 THEN ;ZQU not in list
11500 IF IFOFF ZQUUSE(X3)
11600 THEN
11700 SETOFF ZQUUSE(X3)
11800 ELSE
11900 IF IFOFF ZQUPTD(X3)
12000 THEN
12100 SETON ZQUIVA(X3)
12200 FI
12300 IF IFNEQF X3,ZQUMOD,QVIRTUAL
12400 GOTO TRUE
12500 IFNEQF X3,ZQUNSB,0
12600 THEN ;Set use bit
12700 STACK X1
12800 STACK X2
12900 STACK X3
13000 STACK X4
13100 LF X3,ZQULID(X3)
13200 L X2,XZHE
13300 WHILE
13400 SKIPN X2
13500 DO
13600 STEP X2,ZHB,X1
13700 WHILE
13800 WHENNOT X1,ZQU
13900 DO
14000 LF X4,ZQULID(X1)
14100 IF
14200 IFOFF ZQUIVA(X1)
14300 CAME X3,X4
14400 THEN
14500 SETON ZQUUSE(X1)
14600 FI
14700 STEP X1,ZQU
14800 OD
14900 LF X2,ZHBZHB(X2)
15000 OD
15100 UNSTK X4
15200 UNSTK X3
15300 UNSTK X2
15400 UNSTK X1
15500 FI
15600 FI
15700 FI
15800 FI
15900 OD
16000 LOOP
16100 SETOFF ZQUUSE(X2)
16200 STEP X2,ZQU
16300 AS
16400 WHEN X2,ZQU
16500 GOTO TRUE
16600 SA
16700 REPEAT 0,<[140]
16800 IF
16900 IFON ZQUNOT(X2)
17000 GOTO [JUMPE X4,TRUE
17100 GOTO FALSE]
17200 JUMPN X4,TRUE
17300 THEN ;HIDE
17400 IF IFOFF ZQUPTD(X3) ;ERROR ALREADY GENERATED
17500 THEN
17600 SETON ZQUIVA(X3)
17700 FI
17800 FI
17900 OD
18000 >;[140]
18100 RETURN
18200 EPROC
18300
18400
18500 CAUNP5: PROC
18600 ;[140]
18700 ; Get next visible ZQU
18800 WHILE SKIPE X5
18900 DO
19000 LI X3,0
19100 SKIPN XZHE
19200 RETURN ;All ZQU consumed
19300 STEP XZHE,ZHB,X3
19400 LF XZHE,ZHBZHB(XZHE)
19500 WHILE WHENNOT X3,ZQU
19600 DO
19700 ADDI X5,1
19800 STEP X3,ZQU
19900 OD
20000 OD
20100 SUBI X3,ZQU%S
20200 SUBI X5,1
20300 REPEAT 0,<[140]
20400 IF SKIPE X3
20500 THEN
20600 STEP XZHE,ZHB,X3
20700 ELSE
20800 STEP X3,ZQU
20900 FI
21000 IF
21100 WHEN X3,ZQU
21200 THEN
21300 LI X3,0
21400 LF XZHE,ZHBZHB(XZHE)
21500 JUMPN XZHE,CAUNP5
21600 RETURN
21700 FI
21800 >;[140]
21900 IFON ZQUIVA(X3)
22000 GOTO CAUNP5
22100 L X4,X2
22200 LF X1,ZQULID(X3)
22300 WHILE
22400 WHENNOT X4,ZQU
22500 DO
22600 LF ,ZQULID(X4)
22700 CAMN X1
22800 RETURN
22900 STEP X4,ZQU
23000 OD
23100 LI X4,0
23200 RETURN
23300 EPROC
23400
23500
23600 CAE421: PROC
23700 LF ,ZQULNE(X2)
23800 SKIPE X4
23900 LF ,ZQULNE(X4)
24000 ST YELIN1
24100 ST YELIN2
24200 LF X1,ZQULID(X3)
24300 ERRI1 QE,421 ;Attribute XXXX hidden but not protected
24400 RETURN
24500 EPROC
24600
24700
24800 CAE422: PROC
24900 LF ,ZQULNE(X2)
25000 ST YELIN1
25100 ST YELIN2
25200 LF X1,ZQULID(X2)
25300 ERRI1 QE,422 ;No attribute XXXX visible
25400 RETURN
25500 EPROC
00100 SUBTTL CAPROT [40]
00200
00300
00400 COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
00500
00600 FUNCTION: Make all protected attributes in this class and
00700 its prefix classes inaccessible.
00800
00900 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
01000
01100
01200 CAPROT: PROC
01300 WHENNOT XZHE,ZHB
01400 RETURN
01500 SAVE <X1,XZHE>
01600 STEP XZHE,ZHB,X1
01700 WHILE
01800 WHENNOT X1,ZQU
01900 DO
02000 IF IFOFF ZQUPTD(X1)
02100 THEN
02200 SETON ZQUIVA(X1)
02300 FI
02400 STEP X1,ZQU
02500 OD
02600 LF XZHE,ZHBZHB(XZHE)
02700 SKIPE XZHE
02800 EXEC CAPROT
02900 RETURN
03000 EPROC
00100 SUBTTL BBLK, --- BEGIN SUBBLOCK ---
00200
00300 BBLK.: COMMENT; --- CODE FOR BEGIN OF SUBBLOCK -
00400 READ DECLARATION LIST FROM DF1,
00500 EMIT CODE FOR BLOCK ENTRY
00600 ;
00700
00800 EXEC CARL ;READ QUANTS FOR BLOCK INTO DECLARATION STACK
00900
01000 ASSERT <WHENNOT (XZHE,ZHE)
01100 RFAIL ZHE RECORD EXPECTED
01200 >
01300 IF LI X2,ZHE%S(XZHE)
01400 CAME X2,YDCSTP
01500 THEN ;NO ZQUS IN LIST: INSERT DUMMY ZQU
01600 SETZM X0
01700 SETZM X1
01800 STD X0,(X2)
01900 STD X0,2(X2)
02000 LI ZQU%V
02100 SF ,ZDETYP(X2)
02200 LI ZQU%S(X2)
02300 ST YDCSTP
02400 FI
02500 LF() ZHETYP(XZHE)
02600
02700 ASSERT <CAIL QRBLOCK ;ASSUME QUBLOCK=QRBLOCK+1
02800 CAILE QUBLOCK
02900 RFAIL SUBBLOCK EXPECTED
03000 >
03100 IF ;UNREDUCED SUBBLOCK
03200 CAIE QUBLOCK
03300 THEN
03400 EXEC O2LN1
03500 LF() ZHEFIX(XZHE) ;FIXUP FOR SUBBLOCK PROTOTYPE
03600 OP (MOVEI XSAC,) ;/ MOVEI XSAC,prototype /;
03700
03800 GENFIX ;/ PUSHJ XPDP,CSSB /;
03900 EXEC CAUSTD
04000
04100 GPUSHJ CSSB
04200 ELSE
04300 LF() ZHEBNM(XZHE) ;BLOCK STATE NUMBER
04400 OP (MOVEI XSAC,)
04500 GENABS
04600 IF CAMN XZHE,YZHBXC
04700 THEN ; CURRENT BLOCK NOT ADDRESSABLE BY XCB?
04800 L X1,YBKSTP
04900 WHILE LF ,ZHETYP(XZHE)
05000 CAIE QFOR ; SKIP FOR STATEMENTS
05100 DO
05200 POP X1,XZHE
05300 OD
05400 LF ,ZHEDLV(XZHE)
05500 L X1,YZHBXCB
05600 LF X1,ZHEDLV(X1)
05700 CAMN X1
05800 GOTO FALSE ; OUT FROM IF-THEN
05900 LF ,ZHEDLV(XZHE)
06000 OP (HRL XSAC,(XCB))
06100 GENABS
06200 FI
06300 GPUSHJ CSER
06400 IFON YSWI
06500 EXEC O2LN5
06600 FI
06700 EXEC O2DFTE ;[6] OUTPUT TENTATIVE FIXUP IF ANY
06800 NEXT
00100 SUBTTL BPROG, DEBUG, DO
00200
00300 BPROG.: ASSERT< L YDCSTP
00400 CAME YDCSTB
00500 RFAIL BPROG NOT FIRST SYMBOL IN IC1
00600 >
00700 ; READ STANDARD QUANTITIES USED IN THIS PROGRAM
00800 EXEC CARL
00900 LI 2
01000 SF ,ZHEEBL(XZHE)
01100 ; ALLOCATE OUTERMOST BLOCK
01200 IF IFON YSWCE
01300 THEN ; OUTERMOST BLOCK IS REDUCED SUBBLOCK
01400 L X3,YMPSIZ
01500 SF X3,ZHELEN(XZHE)
01600 L X2,YRELCD
01700 ADDI X2,<QMAXDIS-1>
01800 MOVSI <<QZDR>B<%ZDNTYP+^D18>>
01900 GENABS ; ZDN WORD
02000 LI QMAXDIS+1
02100 GENABS ; ZDR RECORD LENGTH
02200 LOOP SETZ
02300 GENABS
02400 AS CAME X2,YRELCD
02500 GOTO TRUE
02600 SA
02700 LI 2(X2)
02800 ST YCABKB
02900 GENRLD ; DISPLAY ELEMENT
03000 SETZ
03100 GENABS ; RETAD-BLOCKAD ZERO IN OUTERMOST BLOCK
03200 ; BLOCK STARTS HERE
03300 L X4,YRELCD
03400 HRLZI X0,<1B<%ZDNDET+^D18>+<QZPB>B<%ZDNTYP+^D18>> ; ZBIBNM ZERO
03500 GENABS
03600 L X2,YDCSTB
03700 LF ,ZHEFIX(X2)
03800 GENFIX ; FIRST ZBI WORD WITH PROTOTYPE ADDRESS
03900 LI QMAXDIS-3
04000 SF ,ZHBSZD(X2)
04100 LOOP SETZ
04200 GENABS
04300 AS SOJG X3,TRUE
04400 SA
04500 EXEC O2LN1 ; FIRST PROTOTYPE ENTRY
04600 EXEC O2LN2 ; FIRST ENTRY OF LINE TABLE FOR MODULE
04700 L X3,YRELCD
04800 IF ;[144] No runswitches
04900 SKIPE YSWRF
05000 THEN ;Indicate by negative X3 value
05100 SETO X3,
05200 ELSE ;Output the block to REL file
05300 L X2,[-4,,YSWRF]
05400 LOOP ;Output dev:file.ext + one word
05500 L (X2)
05600 GENABS
05700 AS
05800 AOBJN X2,TRUE
05900 SA
06000 L (X2) ;PPN or SFD addr
06100 IF ;SFD
06200 JUMPE FALSE
06300 TLNE -1
06400 THEN ;Relocated address of SFD list
06500 L YRELCD
06600 ADDI 4 ;Follows runswitches
06700 GENRLD
06800 HRL X3,(X2) ;Save SFD table address
06900 ELSE ;Abs word
07000 GENABS
07100 FI
07200 L X2,[-3,,YSWRF+5]
07300 LOOP
07400 L (X2)
07500 GENABS
07600 AS AOBJN X2,TRUE
07700 SA
07800 IF ;SFD list should follow
07900 TLNN X3,-1
08000 THEN ;Copy up to final zero
08100 HLRZ X2,X3
08200 L (X2)
08300 GENABS
08400 L 1(X2)
08500 GENABS
08600 LOOP
08700 L 2(X2)
08800 GENABS
08900 AS SKIPE 2(X2)
09000 AOJA X2,TRUE
09100 SA
09200 FI
09300 FI ;[144]
09400 ; GENERATE INITIALIZING SEQUENCE
09500 L YRELCD ; SAVE ENTRY POINT
09600 ST YCANTRY
09700 L [JRST 1,1]
09800 ADD YRELCD
09900 GENRLD
10000 L [TDZA 1,1]
10100 GENABS
10200 L [JRST 1,1]
10300 ADD YRELCD
10400 GENRLD
10500 OPZ (LI XCB,)
10600 HRR X4
10700 GENRLD
10800 OPZ (JSP 16,)
10900 HRRI OCSP
11000 GENFIX
11100 OPZ (NOP)
11200 IF SKIPL X3
11300 THEN ; NO RUNSWITCH
11400 GENABS
11500 ELSE
11600 HRR X3
11700 GENRLD
11800 FI
11900 FI
12000 L YDCSTB
12100 ST YZHBXC
12200 LI X1,QIDTXT
12300 LF ,ZDCZQU(X1,YDICTB)
12400 ASSERT<SKIPN X0
12500 RFAIL TEXT MISSING IN DICT
12600 >
12700 ST YTEXTI
12800 L X4,XZHE
12900 IF SKIPN XZHE,YDICTB+QIDSIN
13000 THEN
13100 ST XZHE,YSYSI
13200 LF XZHE,ZQUZQU(XZHE)
13300 LF XZHE,ZQUZB(XZHE)
13400 HRR X5,XZHE
13500 ASSERT<
13600 ELSE
13700 OUTSTR [ASCIZ/SYSIN MISSING/]
13800 >
13900 FI
14000 IF SKIPN XZHE,YDICTB+QIDSUT
14100 THEN
14200 LF XZHE,ZQUZQU(XZHE)
14300 LF XZHE,ZQUZB(XZHE)
14400 HRL X5,XZHE
14500 FI
14600 ;[176] L XZHE,X4
14700 ;[176] IFON YSWCE
14800 ;[176] EXEC CAUD
14900 HRR XZHE,X5
15000 EXEC CADISP
15100 HLR XZHE,X5
15200 EXEC CADISP
15300 L XZHE,X4
15400 ;[176] IFON YSWCE
15500 ;[176] EXEC CADISP
15600 IF SKIPN X1,YDICTB+QIDSIM
15700 THEN
15800 LF X1,ZQUZB(X1)
15900 STEP X1,ZHB
16000 WHILE LF X2,ZQULID(X1)
16100 CAIN X2,QIDPRO
16200 DO
16300 STEP X1,ZQU
16400 ASSERT<
16500 CAML X1,YDCSTO
16600 RFAIL PROCESS ZQU NEVER FOUND
16700 >
16800 OD
16900 ST X1,YPROCI
17000 ELSE
17100 OUTSTR [ASCIZ/SIMULATION MISSING/]
17200 FI
17300 EXEC CAUSTD
17400 LI X2,QRELST
17500 EXCH X2,YGAP
17600 GENABS
17700 EXCH X2,YGAP
17800 IFON YSWCE ;[176]
17900 EXEC CARL ;[176]
18000 NEXT
18100
18200 IFN QDEBUG, <
18300 EXTERN CADB
18400 DEBUG.= CADB
18500 >
18600 IFE QDEBUG, <
18700 DEBUG.= ILSYM.
18800 >
18900
19000
19100 DO.: ;--- INSPECT <object expression> DO ---
19200 ;READ ZHB AND POSSIBLE LABEL LIST.
19300 ;COPY ZHB-ZQU LISTS OF INSPECTED CLASS AND ANY PREFIXES,
19400 ;THEN DISPLAY CLASS (AFTER PREFIXES), THEN DISPLAY LABEL LIST.
19500
19600 EXEC CARL
19700 ASSERT< WHENNOT XZHE,ZHB
19800 RFAIL DOZHB NOT FOUND
19900 >
20000 UNDISPLAY ;DEFER DISPLAY OF LABEL LIST
20100 L X1,YORZQU
20200 SF X1,ZHBZQU(XZHE)
20300 SETZM YORZQU
20400 LF() ZQUZB(X1)
20500 SF() ZHBZHB(XZHE)
20600 LF ,ZHEDLV(XZHE)
20700 OP (ST XWAC1,(XCB))
20800 GENABS
20900 BRANCH CACO
00100 SUBTTL EBLK
00200
00300 EBLK.: ;--- END OF SUBBLOCK ---
00400
00500 ASSERT <WHENNOT (XZHE,ZHE)
00600 RFAIL ZHE RECORD EXPECTED
00700 >
00800 LF() ZHETYP(XZHE)
00900 ASSERT <CAIL QRBLOCK
01000 CAILE QUBLOCK
01100 RFAIL SUBBLOCK EXPECTED
01200 >
01300 IF
01400 CAIE QUBLOCK
01500 THEN
01600
01700 ;--UNREDUCED SUBBLOCK
01800
01900 QSADEA=1
02000 IFE QSADEA,<
02100 ; OLD CODE, NO DEALLOCATION BEFORE GC
02200 LF() ZHEDLV(XZHE) ;CODE TO CLEAR DISPLAY ENTRY
02300 OP (SETZM (XCB))
02400 GENABS
02500 >
02600 IFN QSADEA,<
02700 QINLIN=0
02800 QSUBR=1
02900 IFG QINLIN,<
03000 ;DEALLOCATION DONE BY INLINE CODE
03100 L [SETZ XTAC,]
03200 GENABS
03300 LF ,ZHEDLV(XZHE)
03400 OP (EXCH XTAC,(XCB))
03500 GENABS ;CLEAR DISPLAY AND GET RECORD TO XTAC
03600 L [LOWADR(XWAC2)]
03700 GENABS
03800 L [CAMG XTAC,YSADEA(XWAC2)]
03900 GENABS
04000 L YRELCD
04100 ADDI 6
04200 OP (JRST)
04300 EXEC CGRD
04400 L [HRRI XSAC,1(XTAC)]
04500 GENABS
04600 L [SETZM (XTAC)]
04700 GENABS
04800 L [HRL XSAC,XTAC]
04900 GENABS
05000 L [BLT XSAC,@YSATOP(XWAC2)]
05100 GENABS
05200 L [HRRZM XTAC,YSATOP(XWAC2)]
05300 GENABS
05400 >
05500 IFG QSUBR,<
05600 LF ,ZHEDLV(XZHE)
05700 OP (MOVEI XSAC,(XCB))
05800 GENABS
05900 GPUSHJ CSEU
06000 >
06100 >
06200 EXEC CAEB ;UNDISPLAY,OUTPUT PROTOTYPE AND MAP
06300 EXEC CAUSTD
06400 NEXT
06500
06600 FI
06700 ;--REDUCED SUBBLOCK --
06800 IFON YSWI
06900 EXEC O2LN4
07000 UNDISPLAY
07100
07200 ;--Make map of subblock
07300 ;--SQUEEZE OUT QUANTS, LEAVE ZMP RECORDS
07400
07500 L X6,XZHE
07600 EXEC CAMM ;LEAVE POINTER TO END OF QUANTS IN YCAQND
07700 STEP XZHE,ZMP
07800 L X2,XZHE
07900 L X1,YDCSTP ;DECL STACK TOP
08000 SUB X1,YCAQND ;- END OF QUANTS => LENGTH OF CHUNK
08100 IF
08200 JUMPG X1,TRUE ; TO MOVE, IF ANY
08300 THEN
08400 HRL X2,YCAQND ;FORM BLT WORD IN X2
08500 ADDI X1,(XZHE)
08600 BLT X2,(X1) ;MOVE IT
08700 SUB X6,YCAQND ;-LENGTH OF SKIPPED DATA
08800 ADD X6,YDCSTP ;DECREASE STACK POINTER
08900 FI
09000 L X3,YZHET ; WHERE THE MAP WAS JUST PUT
09100 EXEC CAUS
09200 LF X2,ZHEBNM(XZHE)
09300 ASH X2,2
09400 SF X2,ZMPZMP(X3)
09500 STEP X6,ZMP
09600 SETZM (X6)
09700 ST X6,YDCSTP
09800 ; CODE TO UPDATE BLOCK STATE
09900
10000 LF() ZHEBNM(XZHE)
10100 OP (MOVEI XSAC,)
10200 GENABS
10300 IF L X1,YZHBXC
10400 LF X1,ZHEDLV(X1)
10500 LF ,ZHEDLV(XZHE)
10600 CAME X1
10700 THEN ; XCB POINTS TO BASE
10800 L [$ZBIBNM(XCB)]
10900 ELSE
11000 OP (L XTAC,(XCB))
11100 GENABS
11200 L [$ZBIBNM(XTAC)]
11300 FI
11400 GENWRD
11500 OP (DPB XSAC,)
11600 GENREL
11700 ASSERT< LF ,ZHETYP(XZHE)
11800 CAIN QFOR
11900 RFAIL REDUCTION PAST FOR
12000 CAIN QCLASB
12100 RFAIL REDUCTION INTO CLASS
12200 CAIN QINSPE
12300 RFAIL REDUCTION PAST INSPECT
12400 >
12500 NEXT
00100 SUBTTL EDCL, EDPB
00200
00300 EDCL.: ;--- END OF DECLARATIONS IN A CLASS
00400
00500 COMMENT; DEFINE FIXUP F+3, WHERE F IS BASE FIXUP OF CLASS.
00600 OUTPUT A CALL ON CPCD
00700 ;
00800
00900 EXEC CAPL ;COMPILE /MOVEI XSAC,prefix level/
01000 GJRST CPCD
01100 LF(X1) ZHEFIX(XZHE) ;DEFINE ZHEFIX+3 OF THIS CLASS
01200 ADDI X1,3
01300 DEFIX
01400 NEXT
01500
01600
01700 EDPB.: ;--- END DECLARATIONS IN A PREFIXED BLOCK
01800
01900 COMMENT; DEFINE FIXUP+5 OF PREFIXED BLOCK
02000 OUTPUT CALL ON CPPD
02100 ;
02200
02300 GJRST CPPD
02400 LF(X1) ZHEFIX(XZHE)
02500 ADDI X1,3
02600 DEFIX
02700 NEXT
00100 SUBTTL ENDCL
00200
00300 ENDCL.: COMMENT; --- END OF CLASS BODY ---
00400 GENERATE CLASS EXIT CODE. MAKE A TENTATIVE DEFINITION
00500 OF FIXUP F+5 FOR THE CLASS.
00600 UNDISPLAY CLASS ATTRIBUTES.
00700 OUTPUT PROTOTYPE AND MAP.
00800 ;
00900 EXEC CPEND
01000 IF SKIPE X2
01100 THEN
01200 GJRST CPE0
01300 FI
01400 LF(X2) ZHEFIX(XZHE)
01500 EXEC CAEB ;OUTPUT PROTOTYPE AND MAP, STACK DOWN BLOCK STACK
01600 LI X1,5(X2)
01700 HRROS YTENT ;TENTATIVE FIXUP DEFINITION (F+5)
01800 DEFIX
01900 NEXT
00100 SUBTTL CPEND
00200
00300 CPEND: ;FIND OUT IF ANY PREFIX HAS AN EXPLICIT INNER AND COMPILE
00400 ;A JUMP TO STATEMENTS AFTER INNER, OTHERWISE X2 IS 0 ON
00500 ;RETURN.
00600
00700 L X1,XZHE
00800 LOOP
00900 LF(X2) ZHBZHB(X1) ;PREFIX?
01000 JUMPE X2,FALSE
01100 L X1,X2
01200 IFON ZHENOI(X1) ;IF NO INNER IN PREFIX, TRY NEXT PREFIX
01300 GOTO TRUE
01400 LF X2,ZHBZQU(X1)
01500 IF
01600 IFON ZQUSYS(X2) ; SYSTEM PREFIX
01700 GOTO FALSE
01800 IFON ZHBEXT(X1) ;CHECK FOR EXTERNAL PREFIX
01900 THEN ;-- NORMAL PREFIX, COMPILE JRST TO INSTR AFTER INNER
02000 ;-- IN PREFIX --
02100 LF(X2) ZQUIND(X2)
02200 LI 4(X2)
02300 OP (JRST)
02400 GENFIX
02500 ELSE ;-- PREFIX EXTERNAL, COMPILE JRST THROUGH PROTOTYPE --
02600 LF(X2) ZQUIND(X2)
02700 LI (X2)
02800 OP (MOVEI XSAC,)
02900 GENFIX
03000 L [JRST @OFFSET(ZCPIEA)(XSAC)]
03100 GENABS
03200 FI
03300 AS SA
03400 RETURN
00100 SUBTTL ENDDO,ENDFO
00200
00300 ENDDO.: ;--- END OF DO CLAUSE IN INSPECTION ---
00400 ; CLEAR DISPLAY ELEMENT
00500 OPZ (SETZ XWAC1,)
00600 GENABS
00700 LF ,ZHEDLV(XZHE)
00800 OP (EXCH XWAC1,(XCB))
00900 GENABS
01000 LF(X2) ZHEFIX(XZHE)
01100 ST X2,YORFX
01200 LI 3(X2) ;COMPILE JRST TO END OF
01300 OP (JRST) ;INSPECTION
01400 GENFIX
01500 LI X1,2(X2) ;DEFINE AND RELEASE FIXUP F+2
01600 DEFIX
01700 LI X1,2(X2)
01800 CLFIX
01900 EXEC O2AF ; ALLOCATE IT AGAIN FOR NEXT WHEN CLAUSE
02000 LF() ZHBZQU(XZHE)
02100 ST YORZQU ;SAVE ZQU OF QUALIFYING CLASS
02200 LF() ZHBZHB(XZHE) ;AND ZHB OF DECLARING CLASS
02300 ST YORZHB
02400 EXEC CAUNDI ;UNDISPLAY, FOLLOWING ZHB CHAIN,
02500 IFON YSWI
02600 EXEC O2LN4
02700 LI X1,1(X2)
02800 CLFIX ; CLEAR AND REALLOCATE FIX FOR LINE TABLE
02900 LI X1,1(X2)
03000 EXEC O2AF
03100 EXEC CAUS ;THEN UNSTACK THE CONNECTION BLOCK
03200 NEXT
03300
03400
03500 ENDFO.: ;--- END OF FOR STATEMENT ---
03600 ;COMPILE CODE TO GO BACK TO FOR LIST, THEN DEFINE FIXUP F+1.
03700 ;UNDISPLAY LABEL LIST, REMOVE FOR STATEMENT ENTRY FROM STACKS.
03800
03900 LF() ZHEDLV(XZHE) ;DISPL. OF FOR RETURN ADDRESS LOCATION
04000 OP (JRST @(XCB))
04100 GENABS
04200 LF(X2) ZHEFIX(XZHE) ;DEFINE F+1
04300 LI X1,1(X2)
04400 DEFIX
04500 L X1,X2 ;CLEAR F, F+1 FOR REUSE
04600 CLFIX
04700 LI X1,1(X2)
04800 CLFIX
04900 UNDISPLAY
05000 EXEC CAUS
05100 EXEC CAUSTD
05200 SETZM @YDCSTP
05300 NEXT
00100 SUBTTL ENDPR,EPROG,ERROR
00200
00300 ENDPR.: ;--- END PROCEDURE ---
00400 ;COMPILE RETURN FOR PURE PROCEDURE, CALL ON CSEP FOR TYPE PROCEDURE.
00500 ;DEFINE FIXUP F+3 TENTATIVELY, RELEASE F+1, F+2.
00600 ;OUTPUT PROCEDURE PROTOTYPE WITH MAPS OF ENCLOSED,
00700 ;REDUCED SUBBLOCKS.
00800
00900 ASSERT< WHENNOT XZHE,ZHB
01000 RFAIL NOT ZHB AT ENDPROC
01100 >
01200 LF(X1) ZHBZQU(XZHE)
01300 SETOFF ZQUIB(X1)
01400 IF
01500 LF() ZQUTYP(X1)
01600 CAIE QNOTYPE ;NOTYPE PROCEDURE?
01700 THEN
01800 IFE QSADEA,<
01900 L X2,[-3,,[MOVE XSAC,OFFSET(ZDRARE)(XCB) ;RET ADDR AND B.I. ADDR
02000 HLRZ XCB,XSAC ;RESTORE XCB
02100 JRST (XSAC)]] ;EXIT
02200 LOOP
02300 L (X2)
02400 GENABS
02500 AS
02600 INCR X2,TRUE
02700 SA
02800 >
02900 GJRST(CSES) ;SAME AS SWITCH THUNK EXIT
03000 ELSE ;-- TYPE PROCEDURE --
03100 GJRST CSEP
03200 FI
03300 LF(X2) ZHEFIX(XZHE)
03400 EXEC CAEB
03500 LI X1,3(X2)
03600 HRROS YTENT
03700 DEFIX
03800 LI X1,1(X2)
03900 CLFIX
04000 LI X1,2(X2)
04100 CLFIX
04200 NEXT
04300
04400 EPROG.:
04500 L XZHE,YDCSTB
04600 IF IFON YSWCE
04700 THEN ; OUTPUT OUTERMOST PROTOTYPE
04800 EXEC O2LN2 ; LAST LINE NUMBER ENTRY
04900 L X2,YDCSTB
05000 LF X2,ZHEFIX(X2)
05100 LI X1,2(X2)
05200 DEFIX
05300 LI X1,3(X2)
05400 DEFIX
05500 LI X1,4(X2)
05600 DEFIX
05700 EXEC CAEB
05800 GPUSHJ(OCEP)
05900 FI
06000 BRANCH O2EX ;--- END OF PROGRAM ---
06100
06200
06300 ERROR.: ;--- SET FLAG TO GENERATE RTS ERROR INSTEAD OF CODE FOR CURRENT TREE ---
06400
06500 SETON SCERFL
06600 L [RTSERR QDSCON,QSORCERROR] ;[41]
06700 GENABS
06800 NEXT
00100 SUBTTL FIX,FORDO,IENDC,INNER,JUMP
00200
00300 FIX.: ;--- DEFINE FIXUP VALUE ---
00400
00500 INVAL
00600 L X1,X0
00700 DEFIX
00800 NEXT
00900
01000
01100 FORDO.: ;--- DO OF FOR STATEMENT ---
01200 ;COMPILE JUMP TO FIXUP F+1
01300 ;DEFINE AND RELEASE (F+2)
01400 ;IF ANY SIMPLE FOR LIST ELEMENT WAS PRESENT,
01500 ;COMPILE INSTR TO SAVE RET ADDR:
01600 ; MOVEM XSAC,RETURN ADDR(XCB)
01700 ;DISPLAY LABEL LIST, DEFINE FIXUP F,
01800 ;REMOVE NODE FOR CONTROLLED VAR FROM OPERAND STACK
01900
02000 LF(X2) ZHEFIX(XZHE)
02100 LI 1(X2)
02200 OP (JRST)
02300 GENFIX
02400 LI X1,2(X2)
02500 DEFIX
02600 CLFIX
02700 edit(321)
02800 IF ;We had a simple for list element
02900 SKIPL YFORSI ;[321]
03000 THEN ;Code to save return address
03100 LF ,ZHEDLV(XZHE)
03200 edit(326)
03300 OP (HRRZM XSAC,(XCB)) ;[326] Zero left half
03400 GENABS
03500 FI
03600 DISPLAY
03700 LI X1,(X2)
03800 DEFIX
03900 L [QOPSTZ,,YOPST-1]
04000 ST YOPSTP
04100 ;[30] EXEC CAUSTD ;MOVED TO CVBE. (OR)
04200 NEXT
04300
04400
04500
04600 IENDC.: ;--- END OF CLASS WITH NO EXPLICIT "INNER"
04700 ;SET ZHENOI, THEN DO ACTIONS FOR INNER AND ENDCL.
04800
04900 SETON ZHENOI(XZHE)
05000 EXEC INNER.
05100 BRANCH ENDCL. ;RETURN FROM CA MODULE VIA ENDCL.
05200
05300
05400 INNER.: ;--- "INNER" STATEMENT ---
05500 ;OUTPUT CALL ON CPCI, DEFINE ZHEFIX+4
05600
05700 EXEC CAPL ;COMPILE /MOVEI XSAC,prefix level/
05800 GJRST(CPCI)
05900 LF(X1) ZHEFIX(XZHE)
06000 ADDI X1,4
06100 DEFIX
06200 NEXT
06300
06400 JUMP.: ;--- COMPILE JRST TO FIXUP FOLLOWING ---
06500
06600 INVAL
06700 OP (JRST)
06800 GENFIX
06900 NEXT
00100 SUBTTL NOTHR,OPT,OTHER
00200
00300 NOTHR.: ;--- END OF INSPECTION WITHOUT OTHERWISE CLAUSE ---
00400
00500 EXEC OTHER.
00600 LI X1,3(X2)
00700 DEFIX ;DEFINE FIXUP F+3 (END OF INSPECTION)
00800 NEXT
00900
01000
01100 OPT.: ;OPTION CODE FOLLOWS
01200 INVAL
01300 HRRE
01400 IF SKIPGE
01500 THEN ; ON SWITCH
01600 IORM YSWITCH
01700 ELSE ; OFF SWITCH
01800 ANDM YSWITCH
01900 FI
02000 NEXT
02100
02200
02300 OTHER.: ;--- START OF OTHERWISE CLAUSE ---
02400 L XZHE,YDCSTP ; INSPECT ZHB HAS JUST BEEN CAUSED
02500 LF() ZHEDLV(XZHE) ;CODE TO CLEAR DISPLAY ENTRY
02600 OP (SETZM (XCB))
02700 GENABS
02800 LF(X2) ZHEFIX(XZHE)
02900 L X1,X2
03000 SETZM @YDCSTP
03100 DEFIX
03200 EXEC CAUSTD
03300 NEXT
00100 SUBTTL PBEND,PURGE,SEMIC
00200
00300 PBEND.: ;--- END OF PREFIXED BLOCK ---
00400 ;IF ANY PREFIX HAS AN EXPLICIT INNER, COMPILE A JUMP TO THE
00500 ;INNERMOST SUCH PREFIX, OTERWISE SET XCB TO SURROUNDING
00600 ;BLOCK ADDRESS.
00700 ;DEFINE FIXUP F+4 (ZCPIEA).
00800 ;UNDISPLAY, OUTPUT PROTOTYPE AND MAP(S), UNSTACK
00900
01000 EXEC CPEND
01100 IF
01200 SKIPE X2
01300 THEN
01400 LF() ZHBSBL(XZHE)
01500 MOVN
01600 OP (MOVE XCB,(XCB))
01700 GENABS
01800 FI
01900 LF(X2) ZHEFIX(XZHE)
02000 LI X1,4(X2)
02100 DEFIX
02200 LI X1,5(X2)
02300 DEFIX
02400 EXEC CAEB
02500 NEXT
02600
02700 PURGE.: ;--- FLAG A COMPILATION ERROR, PURGE OPERAND STACK
02800 ;AND PARTIAL CODE TREES
02900
03000 L [RTSERR QDSCON,QSORCERROR] ;[41]
03100 GENABS
03200 BRANCH CGPU
03300
03400
03500 SWEND.: ;--- END OF SWITCH DECLARATION
03600 STACK YGAP
03700 STACK YQREL
03800 LI QRELPT
03900 ST YGAP
04000 ST YQREL
04100 HLRZ X1,YCGSWC
04200 DEFIX
04300 HLRZ X1,YCGSWC
04400 AOJ X1,
04500 HRROS YTENT
04600 UNSTK YQREL ; THIS FIXUP IN CODE
04700 DEFIX
04800 HRRZ YCGSWC
04900 GENABS
05000 MOVSI 2
05100 GENABS ; 2,,0
05200 L X2,YZHET
05300 LF X1,ZHEDLV(X2)
05400 HRLZ X1
05500 GENABS ; -DLV,,0
05600
05700 L X2,YZHBXC
05800 LF ,ZHBSZD(X2)
05900 ADDI 3
06000 GENABS ; 0,,ZPCSZD
06100 SETZM YCGSWC
06200 UNSTK YGAP
06300 L YORZHB
06400 ST YZHBXC
06500 EXEC CAUS
06600 SETZM @YDCSTP ;[132]
06700 NEXT
06800 LIT
06900 RELOC 0
07000 VAR
07100 END
07200