Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/cgsa.mac
There are 2 other files named cgsa.mac in the archive. Click here to see a list.
00100 SUBTTL CODE GENERATION
00200 SALL
00300 COMMENT;
00400 AUTHORS: STEFAN ARNBORG, LARS ENDERIN 1-AUG-73
00500
00600 VERSION: 4 [11,14,20,26,32,33,56,65,142,210,251,321]
00700
00800 PURPOSE: CODE GENERATION
00900
01000 CONTENTS: GENERATORS FOR NODES IN EXPRESSION TREE:
01100 ZID, ZCN AND ZNS NODES EXCEPT %PCALL, %NEW, %BEGPB, ETC.
01200 ;
01300 SEARCH SIMMAC,SIMMC2,SIMMCR,SIMRPA
01400 CTITLE CGSA
01500 ; COMPILE OPDEFS
01600 EXTERN CADS,CAUD,CGACSA,CGPD,CGRA
01700 EXTERN CGAS,CGG1,CGG2,CGG3,CGG4,CGG5,CGG7,CGR2,CGR3,CGR4
01800 EXTERN CGIACT ;[14]
01900 EXTERN CGAC
02000 IFN QDEBUG,<
02100 EXTERN DBDT
02200 >
02300 EXTERN O2AD,O2AF,O2GI
02400 EXTERN CGIM,CGMO1,CGIM1,CGMO
02500 EXTERN O2CF,O2DF,O2GA,O2GF,O2GR,O2GW,O2GWD,O2IV
02600 EXTERN QOPSTZ
02700 EXTERN YBKSTP,YELIN2,YGAP,YCGXAC,YCGSWC,YLXIAC,YCGACT,YEXPL,YEXPP,YOPST
02800 EXTERN YCGFX1,YACTAB,YCGFX2,YFORSI,YO2ADI,YO2ADF,YOPCOD,YO2FIX
02900 EXTERN YOPSTB,YOPSTP,YORFOR,YQRELR,YQRELT,YRELPT,YZHET,YRELCD
03000 EXTERN YSYSI,YWARCT
03100 EXTERN .AND,.DEQ,.DIV,.EQ,.EQV,.GRT,.IDIV,.IMP,.LESS,.MINUS
03200 EXTERN .MULT,.NDEQ,.NGRT,.NLESS,.POW,.OR,.PLUS,.UNMIN,.NEQ
03300 EXTERN .BEGPB,.NEW,.PCALL,.IN,.IS,.QUA,.QUAL
03400 EXTERN YCGINS,YORACT,YORFX,YTAC,YZHBXC
03500 INTERN CGAA,CGCCCH,CGEN,CGVA,CGCC,CGCO,CGAD,CGCA,CGPU,CGRN,CGRD,CGLO,CGLO1
03600 IFN QDEBUG,<INTERN CGDB>
03700
03800 EXTERN YCGFOX,YCGICR,YCGISG
03900 DSW SCGFOX,YCGFOX,36
04000 OPDEF ALFIX [PUSHJ XPDP,O2AF]
04100 OPDEF GENRLD [PUSHJ XPDP,CGRD]
04200 OPDEF IFLR [CAIN X6,QLREAL]
04300 OPDEF LR [CAIE X6,QLREAL]
04400 ; MACROS
04500 DEFINE FIRSTOP=<LF XP1,ZNSZNO(XCUR)>
04600 MACINIT
04700 CGINIT
04800 TWOSEG
04900 RELOC 400K
00100 SUBTTL CG ENTRY POINTS
00200 COMMENT;
00300 PURPOSE: ENTRY POINTS FOR CODE GENERATION
00400
00500 ENTRIES: CGEN INITIALIZE FOR COMPILATION OF
00600 A ROOT NODE
00700
00800 CGAD COMPILE ABSOLUTE ADDRESS OF QUANTITY REPRESENTED
00900 BY A NODE OF THE EXPRESSION TREE
01000 TO THE CURRENT TOP OF STACK ACCUMULATOR
01100
01200 CGCA COMPILE DYNAMIC (I.E. MOVABLE) ADDRESS OF A QUANTITY
01300
01400 CGCC COMPILE A BOOLEAN EXPRESSION SO THAT THE NEXT
01500 INSTRUCTION IS SKIPPED IF THE VALUE IS FALSE
01600
01700 CGCO SAME AS CGCC BUT SKIP IF VALUE IS TRUE
01800
01900 CGVA COMPILE VALUE OF EXPRESSION
02000
02100 ENTRY CONDITIONS: CGEN THE ROOT NODE OF THE STATEMENT TO BE COMPILED IS
02200 IN THE BOTTOM OF THE OPERAND STACK
02300
02400 CGAD...CGVA
02500 XP1 CONTAINS THE ADDRESS OF THE ROOT OF THE SUB-
02600 EXPRESSION, YTAC POINTS TO THE LOGICAL (AND INDIRCTLY
02700 TO THE PHYSICAL) ACCUMULATOR OF THE DESTINATION
02800 OF THE RESULT
02900 ACCUMULATORS X1-X6 WILL NOT BE RESTORED
03000 ;
03100 DEFINE INITI(A)=<
03200 STACK YLINK
03300 HRRZM XPDP,YLINK
03400 SETON A
03500 BRANCH CGCM> ; DUMP TREE
03600 CGEN: ASSERT< IFON SCGDB1
03700 EXEC DBDT
03800 >
03900 IFON SCERFL
04000 BRANCH CGPU
04100 LI YACTAB ; START AT BOTTOM ACCUMULATOR
04200 ST YTAC
04300 LI XWAC1 ; WHICH IS PHYSICALLY XWAC1
04400 HRL YOPSTB
04500 ST @YTAC ; AND WILL GET THE ROOT NODE RESULT (IF ANY)
04600 SETZB XCUR,YLINK ; END OF YLINK CHAIN
04700 L XP1,YOPSTB
04800 EXEC CGVA
04900 BRANCH CGPU
05000
05100 CGAD: INITI(SADDRE)
05200
05300 CGCA: INITI(SCADDR)
05400
05500 CGCC: INITI(SCCOND)
05600
05700 CGCO: INITI(SCONDI)
05800
05900 CGVA: INITI(SVALUE)
06000
06100 CGCM: L X4,YLINK
06200 STACK XCUR
06300 STACK YTAC
06400 STACK YCGACT
06500 HRLZ @YTAC
06600 LSH 5
06700 ST YCGACT
06800 L XCUR,XP1
06900 HRLM XCUR,@YTAC
07000 LF X1,ZID%F(XCUR) ; DISCRIMINATE ON NODE TYPE
07100 XCT CGCM.T(X1)
07200 UNSTK YCGACT
07300 UNSTK YTAC
07400 HRLM XCUR,@YTAC
07500 L XP1,XCUR ; RESET XP1
07600 UNSTK XCUR
07700 ASSERT< HRRZ YLINK
07800 CAIE (XPDP)
07900 RFAIL PDSTACK MISMATCH
08000 >
08100 UNSTK YLINK
08200 RETURN
08300
08400 CGCM.T: RFAI [ASCIZ/ZOS NODE IN TREE/]
08500 RFAI [ASCIZ/ZLI NODE IN TREE/]
08600 EXEC ZCN.
08700 EXEC ZID.
08800 EXEC ZNS.
08900 RFAIL ZNN NODE IN TREE BEFORE COMPILATION
00100 SUBTTL ZCN. : LOAD A CONSTANT
00200 COMMENT;
00300 PURPOSE: LOAD A CONSTANT TO REGISTER @YTAC
00400
00500 FUNCTION: THE CONSTANT IS LOADED WITH L OR LD, OR, FOR SHORT OPERANDS
00600 SETZ,,MOVEI,MOVNI OR MOVSI
00700 ENTRY CONDITION: XCUR ADDRESS OF ZCN NODE
00800 X4 FLAGS (SVALUE ETC. ) AND YLINK
00900 XV1 PARAMETER DESCRIPTOR FLAGS IF CALLED FROM CGPAGC
01000 ;
01100 ZCN.: LF X1,ZCNTYP(XCUR)
01200 LF X2,ZCNVAL(XCUR)
01300 IF ; LONG REAL?
01400 CAIE X1,QLREAL
01500 GOTO FALSE
01600 THEN
01700 LD (X2) ; GET VALUE TO X0-X1
01800 GENDW ; OUTPUT DOUBLE CONSTANT
01900 OP (LD)
02000 ADD YCGACT
02100 GENREL
02200 ASSERT< IFOFF SVALUE
02300 RFAIL LONG REAL CONSTANT ADDRESS REQUESTED
02400 >
02500 RETURN
02600 FI
02700 IF ; TEXT?
02800 CAIE X1,QTEXT
02900 GOTO FALSE
03000 THEN
03100 IF ; STRING?
03200 HRRZ X2
03300 JUMPE FALSE
03400 THEN
03500 STACK YQRELR
03600 STACK YQRELT
03700 LI QRELPT
03800 ST YQRELT
03900 HLRZ X2
04000 GENREL ; 0,,START ADDRESS
04100 HRLZ X2
04200 SETZM YQRELR
04300 GENREL ; LENGTH,,0
04400 UNSTK YQRELT
04500 L YRELPT
04600 SUBI 2
04700 IF
04800 IFOFFA SVALUE(X4)
04900 GOTO FALSE
05000 THEN
05100 OP (LD)
05200 ELSE
05300 IFOFFA SADDRE(X4)
05400 OP (LI)
05500 FI
05600 ADD YCGACT
05700 IFONA SADDRE(X4)
05800 HLL XV1 ; COMMUNICATES WITH THUNK COMPILATION
05900 LI X1,QRELPT
06000 ST X1,YQRELR
06100 GENREL
06200 UNSTK YQRELR
06300 RETURN
06400 FI
06500 ; NOTEXT
06600 SETZB X1
06700 GENDW
06800 HLL XV1 ; COMMUNICATES WITH PARAMETER DESCRIPTOR COMPILATION
06900 IF
07000 IFOFFA SVALUE(X4)
07100 GOTO FALSE
07200 THEN
07300 OP (LD)
07400 ADD YCGACT
07500 ELSE
07600 IF IFONA SADDRE(X4)
07700 GOTO FALSE
07800 THEN ; COMPILE ADDRESS
07900 OP (LI)
08000 ADD YCGACT
08100 FI
08200 FI
08300 GENREL
08400 RETURN
08500 FI
08600
08700 CAIN X1,QREF ;[26] ZERO QUAL. IN LH IF NONE
08800 LI X2,NONE
08900
09000 ; ONE WORD CONSTANT: IMMEDIATE INSTRUCTION PREFERRED
09100 ASSERT< IFONA SADDRE(X4)
09200 RFAIL ADDRESS OF LITERAL REQUESTED
09300 IFONA SCADDR(X4)
09400 RFAIL COMPUTED ADDRESS REQUESTED FOR LITERAL
09500 >
09600 IF IFOFFA SVALUE(X4)
09700 GOTO FALSE
09800 THEN ; VALUE
09900 IF JUMPN X2,FALSE
10000 THEN ; ZERO LOAD
10100 MOVSI (SETZ)
10200 GOTO [ADD YCGACT
10300 GENABS
10400 RETURN]
10500 FI
10600 IF TRNE X2,-1
10700 GOTO FALSE
10800 THEN ; RIGHT HALF ZERO
10900 HLR X2
11000 OP (MOVSI)
11100 GOTO [ADD YCGACT
11200 GENABS
11300 RETURN]
11400 FI
11500 IF TLNE X2,-1
11600 GOTO FALSE
11700 THEN ; LEFT HALF ZERO
11800 HRR X2
11900 OP (LI)
12000 GOTO [ADD YCGACT
12100 GENABS
12200 RETURN]
12300 FI
12400 IF MOVN X2
12500 TLNE -1
12600 GOTO FALSE
12700 THEN ; NEGATIVE IMMEDIATE
12800 OP (MOVNI)
12900 GOTO [ADD YCGACT
13000 GENABS
13100 RETURN]
13200 FI
13300 FI
13400 ; NO OPTIMIZED (I.E. IMMEDIATE) LOAD
13500 L X2
13600 GENWRD
13700 OP (L)
13800 ADD YCGACT
13900 GENREL
14000 IF IFOFFA SCONDI(X4)
14100 GOTO FALSE
14200 THEN
14300 ;WARNING 2,REDUNDANT BOOLEAN CONSTANT ;[20] REMOVED
14400 OP (SKIPN)
14500 GOTO [HRR @YTAC
14600 GENABS
14700 RETURN]
14800 FI
14900 IF IFOFFA SCCOND(X4)
15000 GOTO FALSE
15100 THEN
15200 ;WARNING 2,REDUNDANT BOOLEAN CONSTANT ;[20] REMOVED
15300 OP (SKIPE)
15400 GOTO [HRR @YTAC
15500 GENABS
15600 RETURN]
15700 FI
15800 RETURN
15900 ; END ZCN.
00100 SUBTTL ZID. : LOAD AN IDENTIFIER VALUE OR ADDRESS
00200 COMMENT;
00300 PURPOSE: COMPILE AN IDENTIFIER
00400 ;
00500 ZID.:
00600 L X1,XCUR
00700 IF MEMOP
00800 GOTO FALSE
00900 THEN
01000 LF X1,ZIDZQU(XCUR)
01100 GETAD
01200 IF IFOFFA SVALUE(X4)
01300 GOTO FALSE
01400 THEN ; COMPILE LOAD
01500 LF X1,ZIDTYP(XCUR)
01600 MOVSI (L)
01700 CAIE X1,QLREAL
01800 CAIN X1,QTEXT
01900 OP (LD)
02000 ELSE
02100 IF IFOFFA SCONDI(X4)
02200 GOTO FALSE
02300 THEN
02400 MOVSI (SKIPN) ; SKIP IF TRUE
02500 ELSE
02600 IF IFOFFA SCCONDI(X4)
02700 GOTO FALSE
02800 THEN
02900 MOVSI (SKIPE) ; SKIP IF FALSE
03000 ELSE
03100 LI X1,ZNN%V
03200 SF X1,ZNOTYP(XCUR)
03300 LI X1,QCODVA
03400 SF X1,ZNNCOD(XCUR)
03500 IF IFOFFA SCADDR(X4)
03600 GOTO FALSE
03700 THEN ; COMPUTED ADDRESS
03800 ZF ZNNCOD(XCUR)
03900 LDB X2,[INDEXFIELD YO2ADI]
04000 MOVSI (HRLI)
04100 DPB ,[INDEXFIELD YO2ADI]
04200 ST YOPCOD
04300 GENOP ; LOADS OFFSET TO LEFT HALF
04400 L X2
04500 OP (HRR)
04600 ADD YCGACT
04700 GENABS
04800 ELSE
04900 SETZM YOPCOD
05000 SETZM YO2ADI
05100 FI
05200 RETURN
05300 FI
05400 FI
05500 FI
05600 ST YOPCOD
05700 GENOP
05800 ELSE
05900 XZHE=X6
06000 XZQU=X5
06100 XKND=X3
06200 XMOD=X2
06300 XTYP=X4
06400 LF XZQU,ZIDZQU(XCUR)
06500 LF XZHE,ZQUZHE(XZQU)
06600 LF XMOD,ZQUMOD(XZQU)
06700 LF XKND,ZQUKND(XZQU)
06800 LF XTYP,ZQUTYP(XZQU)
06900 L X1,X5 ; USED BY GETAD
07000 IF CAIE XMOD,QNAME
07100 GOTO FALSE
07200 THEN ; NAME MODE PARAMETER
07300 LF X1,ZIDZQU(XCUR)
07400 GETAD
07500 HLLZ YO2ADI
07600 OR [LI 0]
07700 GENABS
07800 SETZB YLXIAC
07900
08000 DPB [INDEXFIELD YO2ADI]
08100 OP (HRLI)
08200 ST YOPCOD
08300 GENOP
08400 SETZM YLXIAC ; XIAC DESTROYED BY PARAMETER ROUTINES;
08500 LI PHFV ; FORMAL VALUE IS STANDARD
08600 LF X1,ZIDZQU(XCUR)
08700 LF X2,ZQUKND(X1)
08800 CAIN X2,QSIMPLE
08900 CAIN XTYP,QLABEL
09000 LI PHFM ; BUT PHFM FOR NON-SIMPLE PARAMETERS
09100 L X2,YLINK
09200 IF IFONA SADDRE(X2)
09300 GOTO TRUE
09400 IFOFFA SCADDRE(X2)
09500 GOTO FALSE
09600 THEN ; ADDRESS REQUESTED
09700 ZF ZNNCOD(XCUR) ;QCODCA
09800 LI X1,ZNN%V
09900 SF X1,ZNOTYP(XCUR)
10000 LI PHFA
10100 FI
10200 LF X1,ZIDTYP(XCUR)
10300 IF CAIE X1,QTEXT
10400 GOTO FALSE
10500 THEN ;THIS SUBTLE PIECE OF CODE DETERMINES THE CORRECT
10600 ;PARAMETER HANDLING ROUTINE FOR TEXTS CALLED BY NAME
10700 ; DISTINGUISHED CASES ARE:
10800 ;T.PUTCHAR, ETC. COMPAD PHFT
10900 ;...:-T COMPVAL PHFT,LD
11000 ;REMAINING COMPAD PHFA
11100 ;REMAINING COMPVAL PHFV
11200 L X2,X0 ; SAVES PHF?
11300 L X1,YLINK ; PATH TO PARENT
11400 L X1,1(X1) ;PARENT NODE ADDRESS
11500 LF ,ZNSGEN(X1)
11600 IF CAIE %DENOT
11700 GOTO FALSE
11800 THEN ;PHFT IF LAST OPERAND
11900 IFOFF ZNOLST(XCUR)
12000 GOTO CGOUT
12100 ASSERT< IFOFF SVALUE
12200 RFAIL TEXT PARAMS
12300 >
12400 LI PHFT
12500 OP (PUSHJ XPDP,)
12600 GENFIX
12700 EXEC CGAC
12800 HRRZ @YTAC
12900 ADD YCGACT ;[YTAC,YTAC(0)]
13000 ADD [LD @1]
13100 GENABS
13200 RETURN
13300 ELSE ; NOT DENOTES
13400 IFON ZNOLST(XCUR)
13500 GOTO CGOUT
13600 IFON SVALUE
13700 GOTO CGOUT
13800 ZF ZNNCOD(XCUR) ;QCODCA
13900 LI X1,ZNN%V
14000 SF X1,ZNOTYP(XCUR)
14100 LI X2,PHFT
14200 FI
14300 CGOUT: L X2
14400 FI
14500 OP (PUSHJ XPDP,)
14600 IFL <PHFA-400K>,<
14700 GENFIX>
14800 IFG <PHFA-400K>,<
14900 GENABS> ; WARNINGG: PARAMETER ROUTINES MUST ALL BE IN HIGH OR LOW SEGMENT
15000 EXEC CGAC
15100 EXEC CGCCCH ; COMPILE SKIP IF CONDITIONAL
15200 ELSE
15300 IF CAIE XKND,QARRAY
15400 GOTO FALSE
15500 THEN
15600 GETAD
15700 MOVSI (L)
15800 ST YOPCOD
15900 GENOP
16000 IF CAIE XTYP,QREF
16100 GOTO FALSE
16200 THEN
16300 AOS YTAC
16400 LF X1,ZQUZQU(XZQU)
16500 GETAD
16600 MOVSI (LI)
16700 ST YOPCOD
16800 GENOP
16900 SOS YTAC
17000 FI
17100 ELSE
17200 IF CAIE XMOD,QREFER
17300 GOTO FALSE
17400 THEN ; REFERENCE MODE PARAMETER
17500 GETAD ; LOAD ZFL INTO @YTAC
17600 MOVSI (LD)
17700 ST YOPCOD
17800 GENOP
17900 ELSE ; DECLARED OR VIRTUAL LABEL,SWITCH OR PROCEDURE
18000 LF XZHE,ZQUZHE(XZQU)
18100 IF IFOFF SADDRE
18200 GOTO FALSE
18300 THEN ; LOAD DECLARING BLOCK TO @YTAC
18400 LF ,ZHEDLV(XZHE)
18500 IF SKIPN
18600 GOTO FALSE
18700 THEN ; NOT IN BASICIO
18800 HRLI (HRRZ (XCB))
18900 ELSE ; BASICIO
19000 ; ZHB OF DECLARING CLASS IN XZHE
19100 L [LOWADR(XSAC)]
19200 GENABS
19300 LI YSYSIN
19400 L X2,YSYSI
19500 LF X2,ZQUZQU(X2) ; INFILE ZQU
19600 LF X2,ZQUZB(X2) ; INFILE ZHB
19700 CAME X2,XZHE ; SKIP IF SYSIN
19800 LI YSYSOUT
19900 OP (L (XSAC))
20000 FI
20100 ADD YCGACT
20200 GENABS
20300 RETURN
20400 FI
20500 GETAD
20600 MOVSI (HRLZI)
20700 ST YOPCOD
20800 CAIE XMOD,QVIRTUAL
20900 GENOP
21000 ASSERT< CAIN XMOD,QVIRTUAL
21100 SETZM YO2ADI
21200 >
21300 IF CAIE XKND,QPROCE
21400 GOTO FALSE
21500 THEN ; SWITCH OR PROCEDURE
21600 IF CAIE XTYP,QLABEL
21700 GOTO FALSE
21800 THEN ; SWITCH
21900 ;FIND BLOCK TO LOAD
22000 L X1,YBKSTP
22100 LF ,ZHEDLV(XZHE)
22200 POP X1,X2
22300 LF X3,ZHEDLV(X2)
22400 CAMLE X0,X3 ; NOTE QUANTS ARE POSITIVE
22500 ;(NOT SIGN EXT)
22600 GOTO .-3 ; FIND DECLARING BLOCK
22700 ; FIND BLOCK THAT CAN BE LOADED
22800 IF IFOFF ZQUIS(XZQU)
22900 GOTO FALSE
23000 THEN ; WARNING FOR INSPECTED SWITCH
23100 LF X1,ZQULID(XZQU)
23200 SETZM YELIN2
23300 ERRI1 QW,Q2.WAR+^D9
23400 ASSERT<NOP [ASCIZ/CONNECTED SWITCH/]
23500 >
23600 ELSE
23700 WHILE LF ,ZHETYP(X2)
23800 CAIE QRBLOC
23900 CAIN QUBLOC ; NOT BLOCKS
24000 GOTO TRUE
24100 CAIN QINSPE ; NOT INSPECT
24200 GOTO TRUE
24300 CAIE QFOR ; AND NOT FOR STMT
24400
24500 GOTO FALSE
24600 DO
24700 POP X1,X2
24800 OD
24900 FI
25000 LF ,ZHEDLV(X2)
25100 SKIPN
25200 LI -2
25300 OP (HRR (XCB))
25400 ADD YCGACT
25500 GENABS
25600 ELSE ; DECLARED OR VIRTUAL PROCEDURE
25700 IF ;[210] System or quick proc
25800 IFON ZQUSYS(XZQU)
25900 GOTO TRUE
26000 LF X1,ZQUZB(XZQU)
26100 LF ,ZHBMFO(X1)
26200 CAIE QEXMQI
26300 GOTO FALSE
26400 THEN
26500 LF X1,ZQULID(XZQU)
26600 ERROR1 15,X1,SYSTEM OR "QUICK" PROCEDURE X PASSED AS PARAMETER
26700 FI ;[210]
26800 LF ,ZHEDLV(XZHE)
26900 ADD YCGACT
27000 ADD [MOVE 1,(XCB)]
27100 ; NOTE DISPLAY IN RIGHT HALFWDS
27200 GENABS
27300 IF IFOFF ZQUIS(XZQU)
27400 GOTO FALSE
27500 THEN ; CONNECTED PROCEDURE
27600 LF XZQU,ZHBZQU(XZHE)
27700 IF ;[65] Connected qual.
27800 IFOFF ZQUIS(XZQU)
27900 GOTO FALSE
28000 THEN ;Use DLV
28100 LF X1,ZQUZHE(XZQU)
28200 LF ,ZHEDLV(X1)
28300 ELSE ;Use SBL of proc
28400 LF XZHE,ZQUZB(XZQU)
28500 LF ,ZHBSBL(XZHE)
28600 SKIPN
28700 LI 2
28800 MOVN
28900 FI ;[65]
29000 OP (HRR (XCB))
29100 ELSE
29200 L [HRR ,XCB]
29300 FI
29400 ADD YCGACT
29500 GENABS
29600 FI
29700 ELSE
29800 IF SKIPE XTYP
29900 SKIPN XKND
30000 GOTO FALSE
30100 THEN; LABEL
30200 ASSERT< CAIE XTYP,QLABEL
30300 RFAIL ZID COMPILATION CODE MISSING
30400 >
30500 IF IFON ZQUIS(XZQU)
30600 GOTO FALSE
30700 THEN
30800 LF ,ZHEEBL(XZHE)
30900 MOVN
31000 ELSE
31100 LF X1,ZQULID(XZQU)
31200 SETZM YELIN2
31300 ERRI1 QW,Q2.WAR+^D9
31400 ASSERT<NOP [ASCIZ/CONNECTED LABEL/]
31500 >
31600 LF ,ZHEDLV(XZHE)
31700 FI
31800 OP (HRR (XCB))
31900 ADD YCGACT
32000 GENABS
32100 SETZ
32200 LF X1,ZHEDLV(XZHE)
32300 MOVN
32400 HRRZ
32500 SF X1,ZLDEBL(,-1)
32600 LF X1,ZHEBNM(XZHE)
32700 SF X1,ZDLBNM(,-1)
32800 GENWRD
32900 OP (MOVE 1,)
33000 ADD YCGACT
33100 GENREL
33200 ELSE ; UNDECLARED OR ILLEGAL OPERAND
33300 L [RTSERR QDSCON,QSORCERR] ;[41]
33400 GENABS
33500 FI
33600 FI
33700 FI
33800 FI
33900 FI
34000 PURGE XTYP,XMOD,XKND,XZHE,XZQU
34100 FI
34200 RETURN
00100 SUBTTL ZNS. : LOAD AN EXPRESSION
00200 ZNS.: LF X1,ZNSGEN(XCUR)
00300 IF IFOFFA SADDRE(X4)
00400 GOTO FALSE
00500 CAIN X1,%DOT
00600 GOTO FALSE ; DECENT ADDRESSES CAN
00700 CAIN X1,%RP
00800 GOTO FALSE ; BE COMPILED FOR %RP AND %DOT
00900 THEN ; ADDRESS OF TEXT: COPY AND STORE DESCRIPTOR
01000 ; WITH COMPUTED ADDRESS IN @YTAC
01100 ASSERT<LF ,ZNSTYP(XCUR)
01200 CAIE QTEXT
01300 RFAIL ADDRESS OF NONTEXT EXPR
01400 >
01500 L XP1,XCUR
01600 COMPVAL ; VALUE TO @YTAC
01700 GPUSHJ(TXDA)
01800 EXEC CGAC
01900 ; TRANSFORM TO ZNN NODE
02000 LI ZNN%V
02100 SF ,ZNOTYP(XCUR)
02200 LI QCODCA
02300 SF ,ZNNCOD(XCUR)
02400 LI X1,ZID%S(XCUR)
02500 REPEAT 0,<;[251] Does not always work correctly
02600 IFOFF ZNOLST(X1)
02700 RETURN
02800 HRRZ @YTAC
02900 ADD [L 1]
03000 ADD YCGACT
03100 GENABS
03200 LI QCODAA
03300 SF ,ZNNCOD(XCUR)
03400 >;[251] End REPEAT 0
03500 RETURN
03600 FI
03700 GOTO GENTAB(X1)
03800 ; GENTAB IS A TABLE WITH ADDRESSES TO THE VARIOUS GENERATORS
03900 ; THE SYMBOL 'S' IS COMPILED AT LABEL '.S'
00100 SUBTTL CGAA
00200 COMMENT;
00300 PURPOSE: COMPILE AN ABSOLUTE ADDRESS FROM AN INTERMEDIATE
00400 RELOCATABLE QUANTITY PRODUCED BY COMPAD (CGAD)
00500
00600 ENTRY: CGAA
00700
00800 OPDEF: MAKEAD
00900
01000 INPUT ARGUMENT: X0 AC TO WHICH THE RESULT WILL BE COMPILED
01100 X1 POINTER TO YACTAB ENTRY DESCRIBING
01200 THE INTERMEDIATE RESULT (X1 HAS THE VALUE OF YTAC WHEN
01300 THE QUANTITY WAS COMPILED).
01400
01500 NORMAL EXIT: RETURN
01600
01700 OUTPUT CONDITION: THE ZNN NODE IS MODIFIED (ZNNCOD=QCODAA) AND CODE FOR THE
01800 COMPUTATION HAS BEEN EMITTED
01900
02000 ;
02100 CGAA: PROC
02200 SAVE <X2,X3,X4,X5>
02300 L X5,X1
02400 L X2,
02500 HLRZ X3,(X5)
02600 LF X4,ZNNCOD(X3)
02700 IF CAIE X4,QCODCA
02800 GOTO FALSE
02900 THEN
03000 ; COMPUTED ADDRESS
03100 HRRZ(X5)
03200 IF CAIE (X2)
03300 GOTO FALSE
03400 THEN ; SOURCE SAME AS TARGET
03500 OP (HLRZ X0,)
03600 GENABS
03700 L X2
03800 OP (ADDM)
03900 GENABS
04000 ELSE ; SOURCE NOT SAME AS TARGET
04100 OP (HLRZ)
04200 DPB X2,[ACFIELD]
04300 ST X4
04400 GENABS
04500 L X4
04600 AND [Z 17,@-1(17)] ; MASK
04700 OR [ADD]
04800 GENABS
04900 FI
05000 ELSE
05100 IF CAIE X4,QCODAR
05200 GOTO FALSE
05300 THEN ; ARRAY ELEMENT
05400 HRLZ X4,(X5)
05500 L X4
05600 LSH 5
05700 ADD X4
05800 ADD [ADD 1,OFFSET(ZARBAD)]
05900 GENABS
06000 HRRZ (X5)
06100 AOS
06200 IF CAMN X0,X2
06300 GOTO FALSE
06400 THEN ; MOVE TO TARGET
06500 OP (L)
06600 DPB X2,[ACFIELD]
06700 GENABS
06800 FI
06900 ELSE
07000 IF CAIE X4,QCODVA
07100 GOTO FALSE
07200 THEN ; VARIABLE
07300 LF X1,ZNNZQU(X3)
07400 GETAD
07500 DPB X2,[ACFIELD YO2ADI]
07600 OPZ (LI)
07700 ST YOPCOD
07800 GENOP
07900 ELSE
08000 IF CAIE X4,QCODAA
08100 GOTO FALSE
08200 THEN ; ADDRESS ALREADY IN @X5
08300 HRRZ (X5)
08400 CAIN (X2)
08500 GOTO FALSE ; SOURCE=TARGET
08600 OP (L)
08700 DPB X2,[ACFIELD]
08800 GENABS
08900 ELSE
09000 IF CAIE X4,QCODRA
09100 GOTO FALSE
09200 THEN
09300 ; REMOTE ADDRESS
09400 LF X4,ZNNZNO(X3)
09500 STEP X4,ZID
09600 ASSERT<
09700 EXCH X4,XP1
09800 MEMOP
09900 RFAIL MAKEAD CALLED FOR NONSIMPLE ATTRIBUTE
10000 EXCH X4,XP1
10100 >
10200 LF X4,ZIDZQU(X4)
10300 LF ,ZQUIND(X4)
10400 OP (LI)
10500 DPB X2,[ACFIELD]
10600 HRLZ X4,(X1)
10700 ADD X4
10800 GENABS
10900 ELSE
11000 ASSERT<
11100 CAIE X4,QCODAA
11200 RFAIL INVALID ZNNCOD IN MAKEAD
11300 >
11400 FI
11500 FI
11600 FI
11700 FI
11800 FI
11900 LI QCODAA
12000 SF ,ZNNCOD(X3)
12100 RETURN
12200 EPROC
00100 SUBTTL CGARCH
00200 COMMENT;
00300 PURPOSE: CHECK THAT ARRAY BOUNDS DO NOT USE LOCAL QUANTITIES
00400
00500 ENTRY CONDITION: FIRST ENTRY: FIRST BOUNDS NODE ADDRESS IN X0
00600 RECURSIVE ENTRIES: NODE IN X0
00700
00800 ;
00900 CGARCH: PROC
01000 SAVE XP1
01100 L XP1,X0
01200 LOOP ; CHECK THIS NODE AND SIBLINGS
01300 IF WHENNOT XP1,ZNS
01400 GOTO FALSE
01500 THEN ; CHECK ZNS FOR LOCAL OBJECT (%THIS)
01600 LF ,ZNSGEN(XP1)
01700 IF CAIE %THIS
01800 GOTO FALSE
01900 THEN ; CHECK IF %THIS REFERS TO CURRENT BLOCK
02000 L X1,YZHET
02100 LF ,ZHETYP(X1)
02200 IF CAIE QCLASB
02300 GOTO FALSE ; NOT CURRENT IF NOT CLASS
02400 THEN LF ,ZHEDLV(X1)
02500 LF X1,ZNSZNO(XP1)
02600 CAMN X1
02700 ERROR2 52,LOCAL OBJECT IN ARRAY DECLARATION
02800 FI
02900 ELSE
03000 LF ,ZNSZNO(XP1)
03100 EXEC CGARCH ; RECURSIVE ENTRY
03200 FI
03300 ELSE
03400 IF WHENNOT XP1,ZID
03500 GOTO FALSE
03600 LF ,ZIDMOD(XP1)
03700 CAIE QDECLARED
03800 GOTO FALSE ; NO WARNING FOR PARAMETERS
03900 THEN
04000 LF X1,ZIDZQU(XP1)
04100 LF ,ZQUZHE(X1)
04200 CAMN YZHET
04300 ERROR2 52,LOCAL OBJECT IN ARRAY DECLARATION
04400 FI
04500 FI
04600 AS IFON ZNOLST(XP1)
04700 GOTO FALSE
04800 STEP XP1,ZNS
04900 GOTO TRUE
05000 SA
05100 RETURN
05200 EPROC
05300
00100 SUBTTL CGCCCH
00200 COMMENT;
00300 PURPOSE: GENERATE SKIPS FOR CGCC/CGCO AFTER VALUE IS COMPUTED
00400 ;
00500 CGCCCH: L X0,YLINK
00600 IFONA SVALUE(X0)
00700 RETURN
00800 IF IFOFFA SCONDI(X0)
00900 GOTO FALSE
01000 THEN L @YTAC
01100 OP (SKIPN) ; SKIP IF TRUE
01200 GENABS
01300 ELSE
01400 IF IFOFFA SCCOND(X0)
01500 GOTO FALSE
01600 THEN
01700 L @YTAC
01800 OP (SKIPE)
01900 GENABS
02000 FI
02100 FI
02200 RETURN
00100 SUBTTL CGDB
00200 COMMENT;
00300 PURPOSE: CG DEBUG HANDLING
00400 ENTRY: CGDB
00500 INPUT ARGUMENT: DEBUG CODE IN X1
00600 OUTPUT ARGUMENT: RELEVANT SWITCH(ES) (RE)SET:
00700 CODE MEANING
00800 0 RESET ALL CGDB SWITCHES
00900 1 CODE GENERATOR NOT ENTERED (CGPU CALLED)
01000 2 PRINT TREE BEFORE GENERATION
01100 ;
01200 IFN <QDEBUG>,<
01300 CGDB: IF
01400 JUMPN X1,FALSE
01500 THEN
01600 SETZM YCGDB ; RESET DEBUG SWITCHES
01700 ELSE
01800 IF CAIE X1,1
01900 GOTO FALSE
02000 THEN
02100 SETON SCERFL
02200 SETON SCGDB1
02300 ELSE
02400 RFAIL INVALID DEBUG CODE TO CG
02500 FI
02600 FI
02700 RETURN
02800 >
00100 SUBTTLE CGLO
00200 COMMENT;
00300 PURPOSE: DETERMINE IF A ZNO NODE CORRESPONDS TO A DOUBLE
00400 LENGTH QUANTITY AT RUN TIME
00500 FUNCTION: ZNO NODE ADDRESS IN X1
00600 CGLO SKIPS IF LONG,
00700 CGLO1 SKIPS IF NOT LONG
00800 ;
00900 CGLO1: STACK X2
01000 AOS -1(XPDP)
01100 HRREI X2,-1
01200 JRST .+3
01300 CGLO: STACK X2
01400 LI X2,1
01500 IF
01600 WHEN X1,ZNN
01700 GOTO FALSE
01800 THEN ; ZNS,ZID OR ZCN
01900 LF ,ZNSTYP(X1)
02000 CAIN QLREAL
02100 ADDM X2,-1(XPDP)
02200 CAIN QTEXT
02300 ADDM X2,-1(XPDP)
02400 ELSE
02500 ; THIS CODE IS ONLY USED WHEN ACCUMULATORS OVERFLOW
02600 ; CALL FROM CGIW
02700 LF ,ZNNCOD(X1)
02800 IF
02900 CAIN QCODAR
03000 GOTO TRUE
03100 CAIE QCODCA
03200 GOTO FALSE
03300 LF ,ZNNTYP(X1)
03400 CAIE QREF
03500 GOTO FALSE
03600 THEN
03700 ADDM X2,-1(XPDP)
03800 FI
03900 FI
04000 UNSTK X2
04100 RETURN
00100 SUBTTLE CGPU
00200 COMMENT;
00300 PURPOSE: PURGE OPERAND STACK AND TREE AREA FOR A STATEMENT CONTAINING
00400 SERIOUS ERRORS, RESET SCERFL IF NOT SCGDB1 IS ON
00500
00600 ENTRY: CGPU
00700
00800 ;
00900 CGPU: LF X3,ZNSGEN(,YOPST)
01000 ; RESET TREE AND OPERAND STACK
01100 L YEXPL
01200 ST YEXPP
01300 L [QOPSTZ,,YOPST-1]
01400 ST YOPSTP
01500 IF ; CHECK IF CONTROLLED VARIABLE SHOULD
01600 ; BE IN THE OPERAND STACK
01700 CAIN X3,%FORST
01800 GOTO TRUE
01900 CAIN X3,%FORSI
02000 GOTO TRUE
02100 CAIN X3,%FORWH
02200 GOTO TRUE
02300 CAIN X3,%CVDE
02400 GOTO TRUE
02500 CAIE X3,%CVBE
02600 GOTO FALSE
02700 THEN
02800 LI X3,YOPST
02900 WHENNOT X3,ZNS
03000 GOTO FALSE
03100 LD YORFOR
03200 L X2,YOPSTP
03300 PUSH X2,
03400 PUSH X2,X1
03500 ST X2,YOPSTP
03600 FI
03700 SETOFF SCERFL
03800 IF L YTAC
03900 CAIN YACTAB
04000 GOTO FALSE
04100 THEN ; ERROR IN CODE GENERATION,RESET AC TABLE
04200
04300 EXEC CGIACT ;[14] INITIATE YCATAB, YTAC, YCGXAC
04400
04500 HRRZ X1,YLINK
04600 WHILE SKIPN (X1)
04700 GOTO FALSE
04800 JUMPE X1,FALSE
04900 DO HRRZ X1,(X1)
05000 OD
05100 ; END OF LINKS REACHED
05200 SOJLE X1,FALSE
05300 WHILE CAIL X1,(XPDP)
05400 GOTO FALSE
05500 DO SUB XPDP,[1,,1]
05600 OD
05700 FI
05800 ASSERT<
05900 IF IFOFF SCGDB1
06000 GOTO FALSE
06100 THEN
06200 SETON SCERFL
06300 FI
06400 >
06500 RETURN
00100 SUBTTL CGRD,CGRN
00200 COMMENT; OUTPUT WORD TO CODE WHICH IS RELOCATED TO
00300 THE CODE AND CONSTANT STREAMS, RESPECTIVELY
00400 ;
00500 CGRD: STACK YQRELR
00600 STACK X0
00700 LI QRELCD
00800 CGRM: ST YQRELR
00900 UNSTK X0
01000 GENREL
01100 UNSTK YQRELR
01200 RETURN
01300
01400 CGRN: STACK YQRELR
01500 STACK X0
01600 LI QRELCN
01700 JRST CGRM
00100 SUBTTL CGSG
00200 COMMENT;
00300 PURPOSE: DETERMINE IF OPTIMIZABLE GOTO STATEMENT PRESENT
00400
00500 ENTRY: CGSG
00600
00700 ENTRY CONDITION: XP1 CONTAINS THE NODE FOR THE DESIGNATIONAL EXPRESSION
00800 YZHBXC POINTS TO THE ZHB CORRESPONDING TO XCB AT RUN TIME
00900
01000 OUTPUT ARGUMENT: X0 CONTAINS:
01100 O NONOPTIMIZABLE CASES
01200 1 XCB NOT CHANGED BUT ZBIBNM CHANGED (TRANSFER
01300 THROUGH REDUCED BLOCKS)
01400 2 ENVIRONMENT NOT CHANGED BY TRANSFER (JRST ONLY)
01500
01600 ;
01700 CGSG: PROC
01800 SAVE <X2,X3,X4,X5,X6>
01900 SETZ X6, ; OUTPUT PARAMETER
02000 IF LF X1,ZNOTYP(XP1)
02100 CAIE X1,ZID%V
02200 GOTO FALSE
02300 LF X1,ZIDMOD(XP1)
02400 CAIE X1,QDECLARED
02500 GOTO FALSE ; NO OPTIMIZATION FOR PARAMETER LABELS
02600 THEN ; ZID OF DECLARED MODE
02700 LF X1,ZIDZQU(XP1)
02800 L X2,YZHBXC
02900 LF X3,ZQUZHE(X1)
03000 LF X4,ZHEDLV(X2)
03100 LF X5,ZHEDLV(X3)
03200 IF CAIE X4,(X5)
03300 GOTO FALSE
03400 IFON ZQUIS(X1)
03500 GOTO FALSE ;NO OPTIMIZATION FOR INSPECTEDLABEL
03600 THEN ; SAME DISPLAY RECORD
03700 AOS X6
03800 LF X4,ZHEBNM(X2)
03900 LF X5,ZHEBNM(X3)
04000 CAIN X4,(X5)
04100 AOS X6
04200 FI
04300 FI
04400 L X6
04500 RETURN
04600 EPROC
00100 SUBTTL GENERATOR FOR %ACTIV
00200 COMMENT;
00300 PURPOSE: COMPILE AN ACTIVATION STATEMENT
00400
00500 ENTRY: ACTIV.
00600
00700 ENTRY CONDITION: %ACTIV(EXPR,EXPR)
00800 %ACTIV(EXPR)
00900 THE ACTIVATE MASK IS IN YORACT
01000
01100 ;
01200 .ACTIV: FIRSTOP
01300 GETAC2
01400 COMPVAL ; COMPILE PROCESS TO XWAC1
01500 IF ; MORE OPERANDS?
01600 IFON ZNOLST(XP1)
01700 GOTO FALSE
01800 THEN ; PROCESS OR TIME TO XWAC2
01900 AOS YTAC
02000 STEP XP1,ZNS
02100 COMPVAL
02200 SOS YTAC
02300 FI
02400 L YORACT
02500 OP (LI)
02600 GENABS ; ACTIVATE MASK TO AC0
02700 GPUSHJ (SUAC)
02800 RELAC2
02900 RETURN
00100 SUBTTL GENERATOR FOR %ADEC
00200 COMMENT;
00300 PURPOSE: COMPILE AN ARRAY DECLARATION SEGMENT
00400
00500 ENTRY: ADEC.
00600
00700 ENTRY CONDITION: %ADEC(%ID,%ID,...%BOUNDS(EXPR,EXPR),%BOUNDS(EXPR,EXPR),...)
00800 ;
00900 .ADEC: FIRSTOP
01000 HRRZ YO2FIX
01100 ST YO2FIX
01200 LF X2,ZIDZQU(XP1)
01300 ASSERT<
01400 WHENNOT XP1,ZID
01500 RFAIL ARRAY NOT ZID
01600 IFNEQF X2,ZQUKND,QARRAY
01700 RFAIL OPERAND OF ADEC NOT ARRAY
01800 >
01900 LF X1,ZQUNSB(X2)
02000 ASSERT<
02100 CAILE X1,QNAC
02200 RFAIL TOO MANY SUBSCRIPTS
02300 >
02400 MOVN XL1,XL1
02500 ; STEP FORWARD TO FIRST BOUNDS PAIR
02600 LOOP
02700 STEP XP1,ZID
02800 AS
02900 WHEN XP1,ZID
03000 GOTO TRUE
03100 SA
03200 L XL2,XP1
03300 ; CHECK LOCAL QUANTITIES IN BOUNDS EXPRESSION
03400 L XP1
03500 EXEC CGARCH ; RECURSIVE SEARCH IN CODE TREE
03600 ; COMPILE AND SAVE BOUNDS
03700 LOOP
03800 GETAC2 ;[14] RESERVE REG. IN PAIRS AND BEFORE COMPVAL
03900 LF XP1,ZNSZNO(XL2)
04000 LOOP ; COMPUTE BOUNDS TO CONSECUTIVE AC:S
04100
04200 COMPVAL
04300 AOS YTAC
04400 AS
04500 IFON ZNOLST(XP1)
04600 GOTO FALSE
04700 ASSERT<WHEN XP1,ZCN
04800 NOP
04900 >
05000 STEP XP1,ZID
05100 GOTO TRUE
05200 SA
05300 AS
05400 IFON ZNOLST(XL2)
05500 GOTO FALSE
05600 STEP XL2,ZID
05700 GOTO TRUE
05800 SA
05900 ; ALLOCATE FIRST ARRAY IN SEGMENT
06000 FIRSTOP
06100 LF X2,ZIDZQU(XP1)
06200 LF XP2,ZQUTYP(X2)
06300 IF CAIE XP2,QREF
06400 GOTO FALSE
06500 THEN ; OUTPUT PROTOTYPE POINTER
06600 LF X1,ZQUZQU(X2)
06700 LF ,ZQUIND(X1)
06800 OP (LI XSAC,)
06900 GENFIX
07000 FI
07100 LF XL2,ZQUNSB(X2)
07200 HRL XL2,XP2
07300 GPUSHJ (CSNA)
07400 EXEC CGIACT ;[14] INITIATE YACTAB AND YTAC
07500 L XL2
07600 GENABS ; NOTE CHANGED CALLING SEQUENCE (CAP 3.5.2)
07700 ; NEW CALL: [LI XSAC,PROT] ONLY REF ARRAY
07800 ; PUSHJ XPDP,CSNA
07900 ; XWD TYPE,NDIM
08000 LOOP
08100 LF X1,ZIDZQU(XP1)
08200 GETAD
08300 OPZ (ST)
08400 ST YOPCOD
08500 GENOP
08600 AS
08700 ; ALLOCATE FOLLOWING ARRAYS WITH COPY
08800 STEP XP1,ZID
08900 WHENNOT XP1,ZID
09000 ; FINISHED
09100 GOTO FALSE
09200 GPUSHJ (CSCA)
09300 GOTO TRUE
09400 SA
09500 RETURN
00100 SUBTTL GENERATOR FOR %BECOM
00200 COMMENT;
00300 PURPOSE: GENERATE CODE FOR ASSIGNMENT
00400
00500 ENTRY: .BECOM
00600
00700 NORMAL EXIT: RETURN
00800
00900 USED ROUTINE: CGAS
01000
01100 ;
01200 .BECOM: GETAC4
01300 LF X1,ZNSZNO(XCUR) ; LHS
01400 LI X2,ZNS%S(X1)
01500 EXEC CGAS
01600 RELAC4
01700 RETURN
00100 SUBTTL GENERATOR FOR %CONVE
00200 COMMENT;
00300 PURPOSE: GENERATE CODE FOR ARITHMETIC (IMPLICIT) CONVERSION
00400
00500 ENTRY: .CONVE
00600
00700 NORMAL EXIT: RETURN
00800
00900 USED ROUTINES: O2GA,O2GF
01000
01100 ;
01200 .CONVE: PROC
01300 SAVE <XL1>
01400 FIRSTOP
01500 LF XL1,ZNSTYP(XP1)
01600 COMPVAL
01700 LF X4,ZNSTYP(XCUR)
01800 ASSERT< CAIN X4,(XL1)
01900 RFAIL SOURCE AND TARGET TYPES EQUAL IN CONVERT
02000 L X4
02100 CAIGE X4,(XL1)
02200 L XL1
02300 CAILE QLREAL
02400 RFAIL NONARITHMETIC TYPES IN CONVERT
02500 >
02600 SETZ
02700 HRRZ X5,@YTAC
02800 IF CAIE X4,QINTEGER
02900 GOTO FALSE
03000 THEN ; TARGET TYPE INTEGER
03100 IF CAIE XL1,QREAL
03200 GOTO FALSE
03300 THEN ; NOT LONG REAL, I.E REAL
03400 OPZ (FIXR)
03500 ELSE ; LONG REAL
03600 ASSERT< LF ,ZNSTYP(XP1)
03700 CAIE QLREAL
03800 RFAIL XL1 DESTROYED OVER COMPVAL
03900 >
04000 WARNING 3,IMPLICIT ARITHMETIC CONVERSION
04100 OPZ (LI XTAC,)
04200 HRR @YTAC
04300 GENABS
04400 GPUSHJ (MACI) ;LONG REAL TO INTEGER CONVERSION
04500 SETZ
04600 FI
04700 ELSE
04800 IF CAIE X4,QREAL
04900 GOTO FALSE
05000 THEN ; TARGET REAL
05100 IF
05200 CAIE XL1,QINTEGER
05300 GOTO FALSE
05400 THEN ;Source integer
05500 OPZ (FLTR)
05600 ELSE ;[142] Source LONG REAL
05700 ; Generate:
05800 ; JUMPGE XTAC,.+3
05900 ; TDNN XTAC,[777,,-1]
06000 ; ADDI XTAC,1
06100 OPZ (JUMPGE)
06200 DPB X5,[ACFIELD]
06300 ADDI 3
06400 ADD YRELCD
06500 GENRLD
06600 HRLOI 777
06700 GENWRD
06800 OP (TDNN)
06900 DPB X5,[ACFIELD]
07000 GENREL
07100 L [ADDI 1]
07200 DPB X5,[ACFIELD]
07300 GENABS
07400 SETZ
07500 FI
07600 ELSE ; LONG REAL
07700 IF CAIE XL1,QINTEGER
07800 GOTO FALSE
07900 THEN
08000 ASSERT< CAIE X4,QLREAL
08100 RFAIL X4 ERROR IN CONVE CGSA
08200 >
08300 WARNING 3,IMPLICIT ARITHMETIC CONVERSION
08400 OPZ (LI XTAC,)
08500 HRR X5
08600 GENABS ; PARAMETER TO MACL
08700 GPUSHJ (MACL)
08800 SETZ
08900 ELSE
09000 L [SETZM 1]
09100 FI
09200 FI
09300 FI
09400 IF JUMPE FALSE
09500 THEN ADD X5
09600 DPB X5,[ACFIELD]
09700 GENABS
09800 FI
09900 RETURN
10000 EPROC
10100
00100 SUBTTL GENERATOR FOR %DOT
00200 COMMENT;
00300 PURPOSE: COMPILE A REMOTE IDENTIFIER
00400
00500 ENTRY: .DOT
00600
00700 NORMAL EXIT: RETURN
00800
00900 ;
01000 .DOT: GETAC3
01100 FIRSTOP
01200 NEXTOP
01300 IF MEMOP
01400 GOTO FALSE
01500 THEN
01600 FIRSTOP
01700 COMPVAL ; COMPILE THE REFERENCE
01800 L X4,YLINK
01900 NEXTOP
02000 LF X1,ZIDZQU(XP1)
02100 LF X3,ZQUIND(X1)
02200 HRLZ X2,@YTAC
02300 L X2
02400 LSH X2,5
02500 ADD X2,
02600 IFONA SCADDR(X4)
02700 DPB ,[INDEXFIELD X2]
02800 ADD X2,X3 ; MAKE Z @YTAC,OFFSET(@YTAC)
02900 OPZ X3,(L)
03000 L X1,XP1
03100 IFLONG
03200 OP X3,(LD)
03300 IFONA SCONDI(X4)
03400 OP X3,(SKIPN)
03500 IFONA SCCONDI(X4)
03600 OP X3,(SKIPE)
03700 IF IFOFFA SADDRE(X4)
03800 GOTO FALSE
03900 THEN
04000 SETF (QZNN)ZNOTYP(XCUR) ; MAKE ZNN NODE
04100 SETF (QCODRA)ZNNCOD(XCUR)
04200 RELAC3
04300 RETURN
04400 FI
04500 IF IFOFFA SCADDR(X4)
04600 GOTO FALSE
04700 THEN
04800 LF ,ZNSZQU(XCUR) ;[1] PUT QUAL IN
04900 SF ,ZNNZQU(XCUR) ; ZNNZQU FIELD
05000 SETF (QZNN)ZNOTYP(XCUR)
05100 SETF (QCODCA)ZNNCOD(XCUR)
05200 OP X3,(HRLI)
05300 FI
05400 L X3
05500 ADD X2
05600 GENABS
05700 ELSE ; NOT SIMPLE OPERAND
05800 LF ,ZIDKND(XP1)
05900 CAIN QARRAY
06000 GOTO TRUE ; ARRAY TREATED AS SIMPLE
06100 ASSERT< CAIE QPROCE
06200 RFAIL REMOTE PROCEDURE EXPECTED
06300 >
06400 ;Here, we must have "X.p", where p is PROCEDURE, X a REF expr.
06500
06600 AOS YTAC
06700 FIRSTOP
06800 LF ,ZNSZQU(XP1) ;[65] Save qualif of "X" in "X.p"
06900 STACK ;[65]
07000 COMPVAL
07100 SOS YTAC
07200 NEXTOP
07300 LF X1,ZIDZQU(XP1)
07400 L X2,X1
07500 GETAD ;GETAD ASSUMES CLASS INST IN @YTAC+1
07600 OPZ (HRLI)
07700 ST YOPCOD
07800 IF ;NOT virtual
07900 LF ,ZIDMOD(XP1)
08000 CAIN QVIRTUAL
08100 GOTO FALSE
08200 THEN GENOP
08300 ASSERT<
08400 ELSE
08500 SETZM YO2ADI
08600 >
08700 FI
08800 LF X1,ZQULID(X2)
08900 IFON ZQUSYS(X2)
09000 ERROR1 15,X1,SYSTEM PROCEDURE XXXX PASSED AS PARAMETER
09100 UNSTK X1 ;[65] Recall qualif of "X"
09200 IF ;[65] The qualifying class was inspected
09300 IFOFF ZQUIS(X1)
09400 GOTO FALSE
09500 THEN ;[65] Use its offset in display
09600 LF X1,ZQUZHE(X1)
09700 LF ,ZHEDLV(X1)
09800 ELSE ;Use SBL from proc ZHB
09900 LF X2,ZQUZHE(X2)
10000 LF ,ZHBSBL(X2)
10100 IF ;No SBL given (standard proc)
10200 JUMPN FALSE
10300 THEN ;Use SBL=2
10400 LI 2
10500 FI
10600 MOVN
10700 FI
10800 OP (HRR (XCB))
10900 ADD YCGACT
11000 GENABS
11100 FI
11200 RELAC3
11300 RETURN
00100 SUBTTL GENERATOR FOR %DENOT
00200 COMMENT;
00300
00400 PURPOSE: COMPILE A DENOTES STATEMENT
00500
00600 ENTRY: .DENOT
00700
00800 NORMAL EXIT: RETURN
00900
01000 USED ROUTINES: .BECOM
01100 ;
01200 .DENOT: BRANCH .BECOM ; REF DENOTES IS IDENTICAL TO BECOMES
01300 ; RETURN
00100 SUBTTL FORSI, Simple FOR element
00200
00300 Comment; Input syntax: <expr> FORSI
00400 Generated code: control-var [:= ! :-] <expr>
00500 JSP XSAC,save return (=fixup(f+2))
00600 If YFORSI is not yet made < 0, make it -1 or -2 to
00700 signify := or :- respectively as noted in CVBE or
00800 CVDE by setting YFORSI to 0 or 1.
00900 ;
01000
01100 .FORSI: SETZM YLXIAC
01200 ;Simple for list element needs special code in FORDO
01300 edit(321)
01400 IF ;[321] Simple FOR list element not already flagged
01500 SKIPGE YFORSI
01600 GOTO FALSE
01700 THEN ;Flag it, -1 for :=, -2 for :-
01800 MOVNS YFORSI
01900 SOS YFORSI
02000 FI
02100 EXEC CGFOAS ;Compute value and store
02200 ;in controlled variable
02300 L YORFX
02400 ADDI 2
02500 OP (JSP XSAC,)
02600 GENFIX
02700 RETURN
00100 SUBTTL FORST, STEP-UNTIL ELEMENT IN FOR STATEMENT
00200
00300 COMMENT; INPUT SYNTAX: <EXPR><EXPR><EXPR> FORST
00400 ;
00500
00600 .FORST: SETZM YLXIAC
00700 EXEC CGFORA ;STORE RETURN ADDRESS, ASSIGN INIT. VALUE
00800 STEP (XP1,ZNS) ;POINT TO NODE FOR INCREMENT (STEP)
00900 ALFIX ;FIXUP FOR LIMIT TEST
01000 ST YCGFX2
01100 CAIL X6,QINTEGER
01200 CAILE X6,QLREAL
01300 BRANCH CGPU ;UNDECLARED CONTROLLED VARIABLE
01400
01500 STACK X6 ;[32] SAVE X6 WITH TYPE INFO
01600 SETOFF SCGFOX ;INCR IS CONSTANT ;[11]
01700 IF ;[11] LONG REAL or not a constant
01800 IFLR
01900 GOTO TRUE
02000 WHEN XP1,ZCN
02100 GOTO FALSE ;[11]
02200 THEN ;WE NEED A SUBROUTINE FOR THE INCREMENT
02300 STEP (XP1,ZNS,XP2)
02400 SETON SCGFOX
02500 EXEC CGYTUP ;ACCOUNT FOR CONTROL VARIABLE
02600 L X3,@YTAC ;RETURN AC (XWAC2 OR XWAC3)
02700 AOS YTAC ;ACCOUNT FOR IT
02800 ;-------------------------;
02900 ; MOVEI xret,limit test ;
03000 ;-------------------------;
03100 L YCGFX2
03200 OP (MOVEI)
03300 DPB X3,[ACFIELD]
03400 GENFIX
03500 ;--FALLS THROUGH TO INCREMENT COMPUTATION
03600 ;-------------------------------------;
03700 ; SUBROUTINE TO COMPUTE THE INCREMENT ;
03800 ;-------------------------------------;
03900 L YRELCD ;SAVE ADDR OF SUBR.
04000 SETZM YLXIAC
04100 ST YCGICR
04200 COMPVAL ;INCR WILL BE COMPUTED TO
04300 ;XWAC3 OR (XWAC4,XWAC5)
04400 ;---------------;
04500 ; JRST (xret) ;
04600 ;---------------;
04700 HRLZI (JRST)
04800 L X3,@YTAC
04900 SOJ X3,
05000 DPB X3,[INDEXFIELD]
05100 GENABS
05200 ELSE ;[11] ONLY FOR CONSTANTS
05300 L YCGFX2
05400 OP (JRST)
05500 GENFIX ;GOTO LIMIT TEST
05600 FI
05700 ;--- CODE TO INCREMENT THE CONTROL VARIABLE ---
05800
05900 L X1,YCGFX1 ;DEFINE AND CLEAR FIXUP FOR INCREMENTATION CODE
06000 DEFIX
06100 CLFIX
06200 SETZM YCGISG ;SIGN(INCREMENT) IF SIGN IS KNOWN,
06300 ;OTHERWISE ZERO
06400 IF ;INCR DIRECTLY ADDRESSABLE
06500 IFON SCGFOX
06600 GOTO FALSE
06700 THEN ;[11] INCR MUST BE A CONSTANT (and NOT long real)
06800 ;[11] IF ;CONSTANT
06900 ;[11] CONST
07000 ;[11] GOTO FALSE
07100 ;[11] THEN
07200 LF X2,ZCNVAL(XP1)
07300 IF ;NONNEGATIVE?
07400 JUMPL X2,FALSE
07500 THEN
07600 IF ;[33] Zero constant
07700 JUMPN X2,FALSE
07800 THEN ;Note that, use (XPDP) LH as flag
07900 HRROS (XPDP)
08000 GOTO FORSTL ;Treat sign as unknown
08100 FI ;[33]
08200 AOS YCGISG
08300 ELSE
08400 SOS YCGISG
08500 FI
08600 ;CHECK FOR STEP +1 OR -1
08700 IF
08800 CAME X2,YCGISG
08900 GOTO FALSE
09000 THEN
09100 MOVSI (AOS)
09200 SKIPGE YCGISG
09300 MOVSI (SOS)
09400 GOTO CGUPCV
09500 FI
09600 COMPVAL
09700 ;[11] ELSE ;[11] ID
09800 ;[11] COMPVAL
09900 ;[11] L [MOVE XWAC3,XWAC1] ;Must be available later
10000 ;[11] GENABS
10100 ;[11] FI
10200 ELSE ;-- GENERAL CASE --- ;[11] INCR NOT A CONSTANT
10300 ;-----------------------;
10400 ; JSP Xret,incr.subr. ;
10500 ;-----------------------;
10600 L YCGICR ;ADDR OF INCR SUBR
10700 OP (JSP)
10800 L X1,@YTAC ;RETURN REG
10900 SOJ X1,
11000 DPB X1,[ACFIELD]
11100 GENRLD
11200 SETZM YLXIAC
11300 ;---INCREMENT TO XWAC1 OR SUM TO (XWAC1-XWAC2)
11400 L [MOVE XWAC1,XWAC3]
11500 HRRZ X6,(XPDP) ;[32] TYPE INFO TO X6
11600 IF ;LONG REAL?
11700 LR
11800 GOTO FALSE
11900 THEN
12000 ;----------------------------------;
12100 ; DMOVE XWAC1,control var ;
12200 ; DFAD XWAC1,XWAC4 ;
12300 ;----------------------------------;
12400 LF X1,ZIDZQU(,YORFOR)
12500 GETAD
12600 KA10WARNING
12700 MOVSI (DMOVE)
12800 ST YOPCOD
12900 LI X1,XWAC1
13000 DPB X1,[ACFIELD YO2ADI]
13100 GENOP
13200 L [DFAD XWAC1,XWAC4]
13300 FI
13400 GENABS
13500 FI
13600 HRRZ X6,(XPDP) ;[32] TYPE INFO TO X6
13700 EXEC CGYTUP
13800 KA10WARNING
13900 L -1+[ADDB ;INTEGER
14000 FADRB ;REAL
14100 DMOVEM ;LONG REAL
14200 ](X6)
14300 CGUPCV: ;--- UPDATE CONTROL VARIABLE
14400 ;-----------------------------------------;
14500 ; op XWAC1,control variable ;
14600 ; op IS ONE OF: AOS SOS ADDB FADRB DMOVEM ;
14700 ;-----------------------------------------;
14800 ST YOPCOD
14900 LF X1,ZIDZQU(,YORFOR)
15000 GETAD
15100 LI X1,XWAC1
15200 DPB X1,[ACFIELD YO2ADI]
15300 GENOP
15400
15500 ;--END OF INCREMENTATION SEQUENCE, COMPILE LIMIT TEST(S)
15600 ;--CONTROL VAR IS COMPUTED TO XWAC1(+XWAC2) AT THIS POINT
15700
15800 FORSTL: ;[33] Go here also if zero constant
15900
16000 STEP (XP1,ZNS)
16100 L X1,YCGFX2 ;DEFINE AND RELEASE FIXUP
16200 DEFIX
16300 CLFIX
16400 ;--COMPILE LIMIT TO REGISTER(S) IF NOT DIRECTLY ADDRESSABLE
16500 SETZM YO2ADF
16600 HRRZ X6,(XPDP) ;[32] TYPE INFO TO X6
16700 IF
16800 MEMOP
16900 GOTO FALSE
17000 THEN
17100 IF
17200 RECTYPE(XP1) IS ZID
17300 GOTO FALSE
17400 THEN
17500 LF X1,ZIDZQU(XP1)
17600 GETAD
17700 ELSE
17800 ;CONSTANT
17900 LF X3,ZCNVAL(XP1)
18000 IF
18100 IFIMMOP
18200 CAIN X6,QREAL
18300 GOTO FALSE
18400 THEN
18500 ST X3,YO2ADI
18600 ELSE
18700 IF
18800 LR
18900 GOTO FALSE
19000 THEN
19100 LD X0,(X3)
19200 GENDW
19300 ELSE
19400 L X0,X3
19500 GENWRD
19600 FI
19700 ST X0,YO2ADI
19800 SOS YO2ADF
19900 SOS YO2ADF
20000 FI
20100 FI
20200 ELSE
20300 AOS YTAC
20400 IFLR
20500 AOS YTAC ; COMPUTE LIMIT TO NEXT FREE AC
20600 COMPVAL
20700 L X0,@YTAC
20800 HRRZ X6,(XPDP) ;[32] TYPE INFO TO X6
20900 IFLR
21000 SOS
21100 SETZM YO2ADF
21200 HRRZM X0,YO2ADI
21300 WARNING 7,EXPRESSION AFTER UNTIL
21400 FI
21500
21600 IF ;SIGN OF INCREMENT UNKNOWN
21700 SKIPE YCGISG
21800 GOTO FALSE
21900 THEN ;-----------------------;
22000 ; JUMPE incr,ctrl stm ;
22100 ; JUMPGE incr,.+4 ;
22200 ;-----------------------;
22300 L YORFX ;[33]
22400 IF ;[33] Constant zero
22500 SKIPL (XPDP)
22600 GOTO FALSE
22700 THEN ;Direct jump, no test needed
22800 OP (JRST)
22900 GENFIX
23000 GOTO FORSTE
23100 FI ;[33]
23200 OP (JUMPE XWAC3,) ;[33]
23300 IFLR ;[33]
23400 OP (JUMPE XWAC4,) ;[33]
23500 GENFIX ;[33]
23600 LI 4
23700 ADD YRELCD
23800 OP (JUMPGE XWAC3,)
23900 IFLR
24000 OP (JUMPGE XWAC4,)
24100 GENRLD
24200 FI
24300 MOVSI X3,(CAML) ;COMPARE INSTR FOR NEG BRANCH
24400 IF
24500 IFIMMOP
24600 CAIN X6,QREAL
24700 GOTO FALSE
24800 THEN
24900 MOVSI X3,(CAIL)
25000 FI
25100 LI XWAC1
25200 DPB [ACFIELD YO2ADI]
25300 L X5,YO2ADI ;SAVE ADDRESS FIELD
25400 ;FIRST COMPILE TEST FOR NEGATIVE INCREMENT, IF NEEDED
25500 SKIPG YCGISG
25600 EXEC CGLIM
25700 ;----------------------------------------------------;
25800 ; _ _ ;
25900 ; ! CAML | ;
26000 ; | CAIL | XWAC1,limit ;
26100 ; |_DFSB _| ;
26200 ; _ _ ;
26300 ; | JRST | ;
26400 ; |_JUMPGE XWAC1, _| controlled statement ;
26500 ;----------------------------------------------------;
26600 IF ;BOTH TESTS ARE NEEDED
26700 SKIPE YCGISG
26800 GOTO FALSE
26900 THEN ;------------;
27000 ; JRST .+3 ;
27100 ;------------;
27200 L YRELCD
27300 ADDI 3
27400 OP (JRST)
27500 GENRLD
27600 ST X5,YO2ADI
27700 FI
27800 AOSE YCGISG ;COMPILE TEST FOR POS INCREMENT
27900 EXEC CGLIM
28000 ;----------------------------------------------------;
28100 ; _ _ ;
28200 ; | CAMG | ;
28300 ; | CAIG | XWAC1,limit ;
28400 ; |_DFSB _| ;
28500 ; _ _ ;
28600 ; | JRST | ;
28700 ; |_JUMPLE XWAC1, _| controlled statement ;
28800 ;----------------------------------------------------;
28900 FORSTE: UNSTK X6 ;[32]
29000 RETURN
00100 SUBTTL FORWH, WHILE ELEMENT IN FOR LOOP
00200
00300 COMMENT; INPUT SYNTAX: <EXPR><EXPR> FORWH
00400 ;
00500
00600 .FORWH: SETZM YLXIAC
00700 L YRELCD ;----------------;
00800 ADD [MOVEI XSAC,2] ; MOVEI XSAC,.+2 ;
00900 STACK YQRELR ;----------------;
01000 LI X1,QRELCD
01100 ST X1,YQRELR
01200 GENREL
01300 UNSTK YQRELR
01400 EXEC CGFORB ;STORE RETURN ADDRESS, ASSIGN CONTROLLED VAR
01500 EXEC CGYTUP
01600 STEP (XP1,ZNS) ;-----------------------;
01700 COMPCC ; reversed boolean test ;
01800 L YORFX ;-----------------------;
01900 OP (JRST) ; JRST controlled stmt ;
02000 GENFIX ;-----------------------;
02100 RETURN
00100 SUBTTL UTILITY ROUTINES USED IN FOR STATEMENT COMPILATION
00200
00300 CGFORA: PROC ;COMPILE CODE TO SAVE RETURN ADDR,
00400 ;THEN COMPILE INITIAL ASSIGNMENT
00500 ;---------------------------------;
00600 ; MOVEI XSAC,update contr.var. ;
00700 ; HRRZM XSAC,displacement (XCB) ;
00800 ;---------------------------------;
00900 ALFIX ;GET FIXUP FOR UPDATING CONTROL VARIABLE
01000 ST YCGFX1
01100 OP (MOVEI XSAC,)
01200 GENFIX
01300 CGFORB: LF ,ZHEDLV(XZHE)
01400 edit(326)
01500 OP (HRRZM XSAC,(XCB)) ;[326] Zero left half
01600 GENABS
01700 CGFOAS: ;--ASSIGNMENT TO CONTROL VARIABLE
01800 FIRSTOP
01900 L X1,XP1
02000 LF X6,ZNSTYP(XP1)
02100 STEP (XP1,ZNS)
02200 L X2,XP1
02300 EXEC CGAS ;ASSIGN THE VALUE
02400 RETURN
02500 EPROC
02600
02700
02800 CGLIM: PROC ;COMPILE CHECK AGAINST LIMIT
02900
03000 CAMG=CAMG
03100 CAML=CAML
03200
03300 SKIPLE YCGISG
03400 ADD X3,[<CAMG-CAML>] ;CHANGE INSTR CODE FOR POS INCR
03500 IFLR
03600 MOVSI X3,(DFSB)
03700 ST X3,YOPCOD
03800 L YO2ADF
03900 IF AOJL FALSE
04000 THEN ; LIMIT NOT IN LITTAB
04100 GENOP
04200 ELSE
04300 L YO2ADI
04400 IOR YOPCOD
04500 EXEC CGRN
04600 ASSERT<SETZM YOPCOD
04700 SETZM YO2ADI
04800 >
04900 FI
05000 L YORFX
05100 OP (JRST) ;JUMP TO CONTROLLED STATEMENT
05200 IF ;LONG REAL?
05300 LR
05400 GOTO FALSE
05500 THEN
05600 OP (JUMPGE XWAC1,)
05700 SKIPLE YCGISG
05800 OP (JUMPLE XWAC1,)
05900 FI
06000 GENFIX
06100 RETURN
06200 EPROC
06300
06400
06500 CGYTUP: PROC ;UPDATE YTAC
06600 AOS YTAC
06700 IFLR ;ONE MORE STEP IF LONG REAL
06800 AOS YTAC
06900 RETURN
07000 EPROC
00100 SUBTTL GENERATOR FOR %GOTO
00200 COMMENT;
00300 PURPOSE: COMPILE A GOTO STATEMENT
00400
00500 ENTRY: GOTO.
00600
00700 NORMAL EXIT: RETURN
00800
00900 USED ROUTINES: CGVA,CGSG
01000
01100 ENTRY CONDITION: XCUR POINTS TO A ZNS %GOTO NODE TO BE COMPILED
01200
01300 EXIT ASSERTION: CODE FOR THE GOTO STATEMENT HAS BEEN COMPILED
01400 ;
01500 .GOTO: PROC
01600 SAVE <XP1>
01700 FIRSTOP
01800 EXEC CGSG ; CHECK FOR LABEL CASE
01900 IF JUMPE FALSE
02000 THEN ; OPTIMIZABLE CASE
02100 LF X3,ZIDZQU(XP1)
02200 SOS
02300 IF JUMPN FALSE
02400 THEN ; SAME DISPLAY BUT STATE NUMBER IS CHANGED
02500 ; EMIT CODE TO UPDATE ZBIBNM
02600 LF X1,ZQUZHE(X3)
02700 LF X5,ZHEBNM(X1)
02800 LI (X5)
02900 OP (LI XWAC1,)
03000 GENABS
03100 L [$ZBIBNM]
03200 GENWRD
03300 OP (DPB XWAC1,)
03400 GENREL
03500 FI
03600 ; GENERATE JUMP
03700 LF ,ZQUIND(X3)
03800 OP (JRST)
03900 GENFIX
04000 RETURN
04100 FI
04200 ; GENERAL CASE: USE CSGO
04300 LF XP1,ZNSZNO(XCUR)
04400 COMPVAL
04500 GPUSHJ (CSGO)
04600 RETURN
04700 EPROC
00100 SUBTTL GENERATOR FOR CONDITIONAL EXPRESSSIONS
00200 COMMENT;
00300 PURPOSE: COMPILE A CONDITIONAL EXPRESSION
00400
00500 ENTRY: IFEX1.
00600
00700 NORMAL EXIT: RETURN
00800
00900 USED ROUTINES: O2AF,CGVA,CGCO,
01000
01100 ENTRY CONDITION: %IFEX1(BOOLEXPR,%IFEX(EXPR,EXPR))
01200 XCUR POINTS TO THE %IFEX1 NODE
01300
01400 EXIT ASSERTION: THE CONDITIONAL VALUE HAS BEEN COMPILED TO @YTAC
01500
01600 ;
01700 .IFEX1: PROC
01800 SAVE <XP1,XL1,XL2>
01900 FIRSTOP
02000 COMPCO ; SKIPPED IF TRUE
02100 EXEC O2AF
02200 L XL2,
02300 EXEC O2AF
02400 L XL1,
02500 OP (JRST)
02600 GENFIX
02700 STEP XP1,ZNS
02800 LF XP1,ZNSZNO(XP1)
02900 COMPVAL
03000 L XL2
03100 OP (JRST)
03200 GENFIX
03300 L X1,XL1
03400 DEFIX
03500 STEP XP1,ZNS
03600 COMPVAL
03700 L X1,XL2
03800 DEFIX
03900 L X1,XL1
04000 CLFIX
04100 L X1,XL2
04200 CLFIX
04300 EXEC CGCCCH
04400 RETURN
04500 EPROC
00100 SUBTTL GENERATOR FOR CONDITIONAL STATEMENTS
00200 COMMENT;
00300 PURPOSE: COMPILE CONDITIONAL STATEMENTS
00400
00500 ENTRY: IFST.,IFTRE.,IFTRU.,
00600
00700 ;
00800 .IFST: ; %IFST(BOOLEXPR)
00900 FIRSTOP
01000 COMPCO
01100 L YORFX
01200 OP (JRST)
01300 GENFIX
01400 RETURN
01500
01600 .IFTRE: ; %IFTRE(BOOLEXPR,EXPR)
01700 FIRSTOP
01800 COMPCO
01900 EXEC O2AF
02000 L XL1,
02100 OP (JRST)
02200 GENFIX
02300 LI X0,ZNS%S
02400 ADDM X0,(XCUR) ;ZNSZNO POINTS TO SECOND OPERAND
02500 EXEC .GOTO
02600 L YORFX
02700 OP (JRST)
02800 GENFIX
02900 L X1,XL1
03000 DEFIX
03100 L X1,XL1
03200 CLFIX
03300 RETURN
03400
03500 .IFTRU: ; %IFTRU(BOOLEXPR,EXPR)
03600 FIRSTOP
03700 STEP XP1,ZID
03800 IF
03900 EXEC CGSG ; SIMPLE GOTO?
04000 CAIE 2
04100 GOTO FALSE
04200 THEN
04300 FIRSTOP
04400 COMPCC
04500 STEP XP1,ZID
04600 LF X1,ZIDZQU(XP1)
04700 LF ,ZQUIND(X1)
04800 OP (JRST)
04900 GENFIX
05000 RETURN
05100 FI
05200 FIRSTOP
05300 COMPCO
05400 EXEC O2AF
05500 L XL1,
05600 OP (JRST)
05700 GENFIX
05800 LI X0,ZNS%S
05900 ADDM X0,(XCUR) ;ZNSZNO POINTS TO SECOND OPERAND
06000 EXEC .GOTO
06100 L X1,XL1
06200 DEFIX
06300 L X1,XL1
06400 CLFIX
06500 RETURN
06600
00100 SUBTTL GENERATOR FOR %INSPE
00200 COMMENT;
00300 PURPOSE: COMPILE CONNECTION
00400
00500 ENTRY: .INSPE
00600
00700 ;
00800 .INSPE: FIRSTOP
00900 COMPVAL
01000 L [CAIN XWAC1,NONE]
01100 GENABS
01200 L YORFX
01300 OP (JRST)
01400 GENFIX
01500 ; NOTE THAT THE OBJECT EXPRESSION IS STORED
01600 ; IN THE DISPLAY BY CODE EMITTED FOR %DO AND %WHEDO
01700 RETURN
00100 SUBTTL GENERATOR FOR %NOT
00200 COMMENT;
00300 PURPOSE: COMPILE NEGATION
00400
00500 ENTRY: .NOT
00600
00700 ENTRY CONDITION: %NOT(BOOLEXPR)
00800
00900 ;
01000 .NOT: FIRSTOP
01100 IF IFOFFA SVALUE(X4)
01200 GOTO FALSE
01300 THEN
01400 IF MEMOP
01500 GOTO FALSE
01600 THEN
01700 WHENNOT XP1,ZID
01800 GOTO FALSE ; WARNING HERE?
01900 LF X1,ZIDZQU(XP1)
02000 GETAD
02100 MOVSI (SETCM)
02200 ST YOPCOD
02300 GENOP
02400 ELSE
02500 COMPVAL
02600 HRRZ X1,@YTAC
02700 MOVSI (SETCA)
02800 DPB X1,[ACFIELD]
02900 GENABS
03000 FI
03100 ELSE
03200 IF IFOFFA SCCOND(X4)
03300 GOTO FALSE
03400 THEN
03500 COMPCO
03600 ELSE
03700 IF IFOFFA SCONDI(X4)
03800 GOTO FALSE
03900 THEN
04000 COMPCC
04100 ASSERT<
04200 ELSE RFAIL ADDRESS OF NON-ADDRESS EXPRESSION
04300 >
04400 FI
04500 FI
04600 FI
04700 RETURN
00100 PAREN:. FIRSTOP
00200 COMPVAL
00300 ASSERT<IFOFF SVALUE
00400 RFAIL ADDRESS OR SKIP OF PARENTHESISED QUANTITY
00500 >
00600 RETURN
00100 SUBTTL GENERATOR FOR SUBSCRIPTED VARIABLES AND SWITCHES
00200 COMMENT;
00300 PURPOSE: COMPILE CODE FOR SWITCH DESIGNATOR OR SUBSCRIPTED VARIABLE
00400
00500 ENTRY: RB.
00600
00700 NORMAL EXIT: RETURN
00800
00900 ERRORS GENERATED: NO
01000 RUN TIME ERRORS: NUMBER OF SUBSCRIPTS, ARRAY BOUNDS ERROR
01100 ;
01200 .RP:.RB: PROC
01300 ; LOCALS:
01400 ; XL1 ORDINAL OF CURRENT SUBSCRIPT
01500 ; XL2 TWICE NUMBER OF SUBSCRIPTS
01600 ; XP1 CURRENT SUBSCRIPT NODE ADDRESS
01700 ; XP2 ACCUMULATOR ARRAY ADDRESS AT RUN TIME
01800 ; XCUR RB NODE ADDRESS WITH ARRAY TYPE
01900 SAVE <XP1,XP2,XL1,XL2>
02000 GETAC3 ; RESERVE THREE CONSECUTIVE ACCUMULATORS
02100 FIRSTOP
02200 IF ; SWITCH: TYPE LABEL
02300 LF ,ZIDTYP(XP1)
02400 CAIE QLABEL
02500 GOTO FALSE
02600 THEN ; SWITCH
02700 SETZ XL1,
02800 IF HRRZ YTAC
02900 CAIG YACTAB
03000 GOTO FALSE
03100 THEN ; NOT TO BOTTOM AC
03200 EXEC CGACSA
03300 EXEC CGPD
03400 SETO XL1,
03500 FI
03600 COMPVAL
03700 AOS YTAC
03800 NEXTOP
03900 COMPVAL
04000 GPUSHJ (CSSC)
04100 SKIPE XL1
04200 EXEC CGRA
04300 RETURN
04400 FI
04500 IF ;[56] REF ARRAY
04600 LF ,ZNSTYP(XP1)
04700 CAIE QREF
04800 GOTO FALSE
04900 THEN ;Copy ZIDZDE (=ZNSZQU) to ZNNZQU(XCUR)
05000 LF ,ZIDZDE(XP1)
05100 SF ,ZNNZQU(XCUR)
05200 FI ;[56]
05300 COMPVAL ;Array address
05400 SETZB XL1,XL2
05500 ; DETERMINE NUMBER OF SUBSCRIPTS
05600 L XP2,@YTAC ; FIRST WORK AC WITH ARRAY
05700 L X1,XP1
05800 LOOP
05900 STEP X1,ZID
06000 AOS XL2
06100 AS
06200 IFOFF ZNOLST(X1)
06300 GOTO TRUE
06400 SA
06500 ; DETERMINE IF SUBSCRIPT NUMBER CHECK NEEDED
06600 LF X1,ZNSMOD(XP1)
06700 IF CAIN X1,QDECLARED
06800 GOTO FALSE
06900 IFOFF YSWA
07000 GOTO FALSE
07100 THEN ; DYNAMIC SUBSCRIPT NUMBER CHECK
07200 L [$ZARSUB]
07300 DPB XP2,[INDEXFIELD] ; SET BASE AC IN INDEX FIELD OF POINTER
07400 GENWRD
07500 OP (LDB)
07600 GENREL
07700 OP (CAIE)
07800 HRR XL2
07900 GENABS
08000 L [RTSERR QNSUBERR]
08100 GENABS
08200 FI
08300 AOS YTAC ; FIRST SUBSCRIPT TO SECOND AC
08400 ASH XL2,1 ; FROM NOW XL2 HAS 2*NSUBSCRIPTS
08500 LOOP
08600 AOS XL1 ; NEXT SUBSCRIPT
08700 STEP XP1,ZID
08800 COMPVAL
08900 IF IFOFF YSWA
09000 GOTO FALSE ; NO SUBSCRIPT CHECKING
09100 THEN ; SUBSCRIPT CHECK
09200 L [CAML OFFSET(ZARLOW)]
09300 L X1,@YTAC
09400 DPB X1,[ACFIELD]
09500 DPB XP2,[INDEXFIELD]
09600 ADD XL1
09700 ADD XL1
09800 ST YCGINS
09900 GENABS
10000 LI 1
10100 ADD YCGINS
10200 CAMLE=CAMLE ; THESE STATEMENTS ARE DUE TO UNKNOWN MACRO-10 FEATURES
10300 CAML=CAML
10400 ADD [<CAMLE-CAML>]
10500 PURGE CAMLE,CAMGE
10600 GENABS
10700 L [RTSERR QBOUNDSERR]
10800 GENABS
10900 FI
11000 IF CAIN XL1,1
11100 GOTO FALSE
11200 THEN ; NOT FIRST SUBSCRIPT
11300 LI <<<OFFSET(ZARLOW)>+2+<OFFSET(ZARDOP)>>&77777>
11400 OP (IMUL)
11500 LI X1,2(XP2)
11600 DPB X1,[ACFIELD]
11700 DPB XP2,[INDEXFIELD]
11800 ADD XL2
11900 ADD XL1
12000 GENABS
12100 HRRZ XP2
12200 DPB XP2,[ACFIELD]
12300 ADD [ADD 1,2]
12400 GENABS
12500 ELSE ; HIGHER SUBSCRIPTS EVALUATED
12600 AOS YTAC ; TO 3RD AC
12700 FI
12800 AS ; MORE SUBSCRIPTS?
12900 IFOFF ZNOLST(XP1)
13000 GOTO TRUE
13100 SA
13200 HRRZ XP2
13300 DPB XP2,[ACFIELD]
13400 ADD [ADD 1,1]
13500 LF X1,ZNSTYP(XCUR)
13600 CAIE X1,QTEXT
13700 CAIN X1,QLREAL
13800 GENABS ; DOUBLE INDEX FOR TEXT AND LONG REAL
13900 IF IFON SADDRE
14000 GOTO FALSE
14100 THEN
14200 SETZ
14300 DPB XP2,[ACFIELD]
14400 DPB XP2,[INDEXFIELD]
14500 L XL1,
14600 ADD [ADD 1,OFFSET(ZARBAD)]
14700 GENABS
14800 ELSE
14900 LI QZNN
15000 SF ,ZNOTYP(XCUR)
15100 LI QCODAR
15200 SF ,ZNNCOD(XCUR)
15300 RELAC3
15400 RETURN
15500 FI
15600 IF IFOFF SCADDR
15700 GOTO FALSE
15800 THEN ; COMPUTED ADDRESS
15900 OPZ (SUBI 1,)
16000 ADD XL1 ; [Z XTOP,(XTOP)]
16100 GENABS
16200 OPZ (HRLI (1))
16300 ADD XL1
16400 LI X1,QZNN
16500 SF X1,ZNOTYP(XCUR)
16600 LI X1,QCODCA
16700 SF X1,ZNNCOD(XCUR)
16800 ELSE ; COMPUTE ABSOLUTE ADDRESS
16900 IF IFOFF SVALUE
17000 GOTO FALSE
17100 THEN
17200 LF X1,ZNSTYP(XCUR)
17300 L XL1
17400 OPZ X2,(L (1))
17500 CAIE X1,QLREAL
17600 CAIN X1,QTEXT
17700 OPZ X2,(LD (1))
17800 ELSE
17900 IF IFOFF SCCOND
18000 GOTO FALSE
18100 THEN
18200 OPZ X2,(SKIPE (1))
18300 ELSE
18400 ASSERT< IFOFF SCONDI
18500 RFAIL UNEXPECTED COMPCASE
18600 >
18700 OPZ X2,(SKIPN (1))
18800 FI
18900 FI
19000 L XL1
19100 ADD X2
19200 FI
19300 GENABS
19400 RELAC3
19500 RETURN
19600 EPROC
00100 SUBTTL %SWEL, SWITCH ELEMENT
00200 COMMENT;
00300 PURPOSE: COMPILE A SWITCH ELEMENT INTO A SWITCH RECORD
00400
00500 ENTRY: SWEL.
00600
00700 ;
00800 SIMPLELABEL=1B<%ZNOTER>+1B<%ZNOLST>+<QZID>B<%ZNOTYP>+<QSIMPLE>B<%ZIDKND>+<QLABEL>B<%ZIDTYP>
00900 SIMPLE=SIMPLE+<QDECLARED>B<%ZIDMOD>
01000 .SWEL:
01100 STACK YGAP
01200 LI QRELPT
01300 ST YGAP
01400 FIRSTOP
01500 HLRZ (XP1)
01600 IF CAIE (SIMPLELABEL)
01700 GOTO FALSE
01800 THEN
01900 LF X2,ZIDZQU(XP1)
02000 LF X3,ZQUZHE(XP1)
02100 LF X0,ZQUIND(X2)
02200 LF X1,ZHEEBL(X3)
02300 MOVN X1,X1
02400 HRL X1
02500 GENFIX ; LABEL ADDRESS
02600 IF
02700 LF ,ZHETYP(X3)
02800 CAIE QFOR
02900 GOTO FALSE
03000 THEN
03100 HRRZ X1,YBKSTP
03200 LOOP
03300 SOJ X1,
03400 LF X3,ZBSZHE(X1)
03500 AS LF ,ZHETYP(X3)
03600 CAIN QFOR
03700 GOTO TRUE
03800 SA
03900 FI
04000 LF X1,ZHEDLV(X3)
04100 LF ,ZHEBNM(X3)
04200 HRL X1
04300 GENABS
04400 UNSTK YGAP
04500 ELSE
04600 STACK YQRELT
04700 LI QRELPT
04800 ST YQRELT
04900 L YRELCD
05000 GENRLD
05100 SETZ
05200 GENABS
05300 UNSTK YQRELT
05400 UNSTK YGAP
05500 SETZM YLXIAC
05600 COMPVAL
05700 GJRST (CSES) ; END SWITCH THUNK
05800 FI
05900 AOS YCGSWC
06000 RETURN
00100 SUBTTL THIS,WHEDO,WHILE
00200 COMMENT;
00300 PURPOSE: COMPILE A LOCAL OBJECT
00400
00500 ENTRY: THIS.
00600
00700 ENTRY CONDITION: THE DISPLAY LEVEL USED TO ACCESS THE OBJECT IS IN ZNSZQU
00800 OF THE CURRENT (%THIS) NODE
00900
01000 ;
01100 .THIS: HRRZ X1,@YTAC
01200 LF ,ZNSZNO(XCUR)
01300 IORI 777000
01400 OP (HRRZ ,(XCB))
01500 DPB X1,[ACFIELD]
01600 GENABS
01700 RETURN
01800
01900
02000
02100
02200
02300 .WHEDO: ; WHEN CLAUSE ENTERED AT RUN TIME
02400 ; WITH NON-NULL OBJ.EXPRESSION
02500 ; IN XWAC1
02600 LF ,ZHEDLV(XZHE)
02700 OP (ST XWAC1,(XCB)) ; STORE EXPRESSION IN DISPLAY
02800 GENABS
02900 L [LF XWAC2,ZBIZPR(XWAC1)]
03000 GENABS ; LOAD PROTOTYPE OF OBJ. EXPRESSION
03100 FIRSTOP
03200 LF X1,ZIDZQU(XP1)
03300 LF ,ZQUIND(X1) ; PROTOTYPE FIXUP
03400 OP (CAIN XWAC2,)
03500 GENFIX
03600 L X4,YRELCD
03700 LI 4(X4)
03800 OP (JRST)
03900 L X3,YQRELR
04000 LI X1,QRELCD
04100 ST X1,YQRELR
04200 GENREL ; JRST .+4
04300 L [SKIPN XWAC2,OFFSET(ZCPZCP)(XWAC2)]
04400 GENABS
04500 L X1,YZHET
04600 LF ,ZHEFIX(X1)
04700 OP (JRST)
04800 ADDI 2
04900 GENFIX ; JRST NEXTWHEN
05000 LI -1(X4)
05100 OP (JRST)
05200 GENREL ; JRST .-4
05300 ST X3,YQRELR
05400 RETURN
05500
05600 .WHILE: L X1,YORFX
05700 DEFIX
05800 FIRSTOP
05900 IF WHENNOT XP1,ZCN
06000 GOTO TRUE
06100 LF ,ZCNVAL(XP1)
06200 SKIPE ; SKIP IF FALSE
06300 GOTO FALSE ; NOTHING IF WHILE TRUE DO
06400 THEN
06500 COMPCO
06600 L YORFX
06700 ADD [JRST 1]
06800 GENFIX
06900 FI
07000 RETURN
00100 SUBTTL GENERATOR TABLE
00200
00300 GENTAB:
00400 DEFINE GENS(N,V,D2,D3)=<
00500 IFG <%BBLK-V>,<
00600 REPEAT <V-$$LC-1>,<
00700 RFAI [ASCIZ/ILLEGAL GENERATOR IN CG/]>
00800 $$LC=V
00900 IFDEF .'N,<
01000 GOTO .'N>
01100 IFNDEF .'N,<
01200 RFAI [ASCIZ/UNDEFINED GENERATOR IN CG/]
01300 >
01400 >>
01500 $$LC=-1
01600 SYMB 6,1,GENS
01700 LIT
01800 RELOC
01900 VAR
02000 END