Google
 

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