perm filename CA.MAC[SIM,SYS] blob sn#459974 filedate 1979-07-22 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00027 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002		SUBTTL	LARS ENDERIN JUNE 1973
C00006 00003		SUBTTL	MACROS, OPDEFS
C00007 00004		SUBTTL	TEMPORARY DEFINITIONS
C00008 00005		SUBTTL	CAEB
C00019 00006	===ROUTINE CAEBVM===
C00021 00007		SUBTTL	CA DISPATCH TABLE
C00022 00008		SUBTTL	CAMM (MAKE MAP OF BLOCK)
C00026 00009		SUBTTL	CACO
C00029 00010		SUBTTL	CAPL,CAUS
C00031 00011		SUBTTL	CARDX3,CAFQX2
C00032 00012		SUBTTL	CADS (DISPLAY)
C00034 00013		SUBTTL	CAUD (UNDISPLAY)
C00036 00014		SUBTTL	CADISP,CAUNDI
C00038 00015		SUBTTL	CAUNPR	[40]
C00042 00016		SUBTTL	CAPROT [40]
C00043 00017		SUBTTL	BBLK, --- BEGIN SUBBLOCK ---
C00046 00018		SUBTTL	BPROG, DEBUG, DO
C00051 00019		SUBTTL	EBLK
C00055 00020		SUBTTL	EDCL, EDPB
C00056 00021		SUBTTL	ENDCL
C00057 00022		SUBTTL	CPEND
C00059 00023		SUBTTL	ENDDO,ENDFO
C00061 00024		SUBTTL	ENDPR,EPROG,ERROR
C00064 00025		SUBTTL	FIX,FORDO,IENDC,INNER,JUMP
C00066 00026		SUBTTL	NOTHR,OPT,OTHER
C00067 00027		SUBTTL	PBEND,PURGE,SEMIC
C00069 ENDMK
C⊗;
	SUBTTL	LARS ENDERIN JUNE 1973

COMMENT;	==== MODULE CA ====

AUTHOR:		LARS ENDERIN

VERSION:	2	[40]

PURPOSE:	HANDLES CONTROL SYMBOLS (I E NEITHER OPERATORS NOR
		OPERANDS)

CONTENTS:	ACTIONS FOR BBLK,BPROG, ETC. (SYMBOL TYPE SYMBT2)

ENTRY:		CAEN

;
	TWOSEG
	RELOC	400K
	SEARCH	SIMMAC,SIMMC2,SIMMCR,SIMRPA
	CTITLE	CA
	SALL
	MACINIT

;--- EXTERNAL ROUTINES

IFN	QDEBUG,<EXTERN	YCADB,O2DB1,O2DB2,O2DB3
	>
	EXTERN	CGAD,CGCA,CGCC,CGCO,CGIM,CGIM1,CGMO,CGMO1,CGVA,O2AF,O2SM
	EXTERN	O2AB,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4
EXTERN	CARL,CGPU
EXTERN	O2EX,M2CO
EXTERN	O2LN1,O2LN2,O2LN3,O2LN4,O2LN5,O2LN6
EXTERN	O2AD,O2CF,O2DF,O2DFTE,O2GA,O2GF,O2GI,O2GR,O2GW,O2GWD,O2IV
EXTERN	CGLO,CGLO1,CGRD

;--- EXTERNAL DATA

	EXTERN	QOPSTZ
	EXTERN	YUNDEC,YRELLT,YRELST,YORFX,YQRELR,YQRELL,YQRELT,YCANTR,YCGSWC,YQREL,YCASM
EXTERN	YDCSTB,YTEXTI,YPROCI,YSIMUI,YSYSI,YSYSO,YSWCHA
EXTERN	YCALID,YCAMTC,YCAQND,YCAZMP,YCAZHE,YLXIAC
EXTERN	YELIN1,YELIN2	;[40]
EXTERN	YBKST,YBKSTP,YCERFL,YDCSTO,YDCSTP,YDICTB,YEXPL,YEXPP
EXTERN	YFORSI,YGAP,YLINE,YMPSIZ,YCABKB
EXTERN	YOPSTB,YOPST,YOPSTP,YORZHB,YORZQU,YO2ZSD
EXTERN	YRDSTO,YRDSTP,YRELPT,YSTATM,YTENT,YZHET,YZHBXC
	EXTERN	YRELCD,YSWRF

INTERN	CACO,CADS,CADISP,CAEN,CADS,CAUD,CAUNDI,CAUS,CAUSTD,ERROR.
INTERN	CAPROT,CAUNPR	;[40]
	SUBTTL	MACROS, OPDEFS

;--- MACRO DEFINITIONS
	CGINIT

DEFINE $$$DO	<GOTO	FALSE>
DEFINE $$$THEN	<GOTO	FALSE>

IFE QDEBUG,<DEFINE CHKOFS(F)<>
>
IFN QDEBUG,<
DEFINE	CHKOFS(F)<
 IRP F,<
 IFN <<WOFS>&777777-OFFSET(F)>,<
  CFAIL WRONG OFFSET: F
>>>
 OPDEF	RH	[POINT	18,0,35]
 RH==RH
 DEFINE RIGHTHALF(A)<
 IFN <RH-<<$'A>&<777777B17>>>,
  <CFAIL	A IS NOT IN RH>>
>
DEFINE NEXTWORD<WOFS==WOFS+1>

;--- OPDEF'S

OPDEF	NEXT	[POPJ	XPDP,]
OPDEF	UNDISP	[PUSHJ	XPDP,CAUD]
	SUBTTL	TEMPORARY DEFINITIONS

DEFINE	D(X)	<
X=..N
..N=..N+1
>

;MISCELLANEOUS:

..N=100
D EILSYM
D EDCOFL
	SUBTTL	CAEB

COMMENT;	=== ROUTINE CAEB ===
PURPOSE:	CALLED AT END OF UNREDUCED SUBBLOCK, CLASS,
		PROCEDURE OR PREFIXED BLOCK.
		OUTPUTS PROTOTYPE AND VARIABLE MAP (FOR GARBAGE COLLECTOR
		AND ENTRY INTO REDUCED SUBBLOCK) FOR THE BLOCK AND ANY
		ENCLOSED, REDUCED SUBBLOCKS. UNDISPLAYS THE ZQU RECORDS.
		REMOVES THE BLOCK FROM DSTACK EXCEPT WHEN IT IS A CLASS BLOCK.
		OUTPUTS LINE AND SYMBOL TABLE ENTRIES FOR BLOCK
ENTRY:		EXEC CAEB
EXIT:		RETURN
USES:		CADS,CAMM,CAUNDI,CAUD,O2GA,O2GF,O2GP,O2GR,O2LN4,CAUS,CAFQX2
INPUT:		XZHE POINTS TO ZHE OR ZHB FOR TERMINATING BLOCK
;

XFIX=X5


CAEB:	PROC
	SAVE	<X2,X3,X4,X5,X6,XP1>
	EXEC	O2LN4
	L	YRELST
	ST	YCASM	; SYMBOL TABLE START
; RESET YZHBXCB
	IF	CAME	XZHE,YZHBXC
	THEN
		HRRZ	X1,YBKSTP
		LOOP	SOS	X1
		AS
			HRRZ	X2,(X1)
			CAIG	X1,YBKST
			GOTO	FALSE
			WHENNOT	X2,ZHB
			GOTO	TRUE
			IFEQF	X2,ZHETYP,QINSPE
			GOTO	TRUE
		SA
		ST	X2,YZHBXC
	FI
	ST	XZHE,YCAZHE
	SETZM	XP1
	IF
		LF()	ZHETYP(XZHE)
		CAIE	QPROCB
	THEN		;UNDISPLAY PROC QUANTS
		ASSERT<	WHENNOT	XZHE,ZHB
			RFAIL	PROCEDURE ZHE FOUND NOT ZHB
		>
		LF	(X1)ZHBZQU(XZHE)
		LF	(X1)ZQUTYP(X1)
		SF	(X1)ZPCTYP(,XP1-OFFSET(ZPCTYP))
		LF(XZHE)ZHBZE(XZHE)
		UNDISPLAY
		EXCH	XZHE,YCAZHE
		UNDISPLAY
		EXCH	XZHE,YCAZHE
	ELSE
		EXEC	CAUNDI		;UNDISPLAY FOLLOWING ZHBZHB CHAIN
		EXEC	CAPROT	;[40]
	FI
	LI	X6,YCAZMP	;MAKE A MAP
	EXEC	CAMM
	STACK	YQRELR
	; OUTPUT ZSM?
	LI	X3,QRELID
	EXCH	X3,YQRELR
	LI	QRELST
	ST	YQRELT
	IF	LF	,ZHETYP(XZHE)
		CAIN	QPROCB
		GOTO	TRUE
		CAIE	QCLASB
	THEN	; OUTPUT ZSMRNM
		EXCH	XZHE,YCAZHE
		LF	X2,ZHBZQU(XZHE)
		IF	IFOFF	ZQUGLOB(X2)
		THEN	; PRECEDE SYMBOL TABLE WITH LINE NUMBER TABLE POINTER
			LI	QRELLT
			ST	YQRELR
			L	YRELLT
			SOS
			GENREL
			LI	QRELID
			ST	YQRELR
		FI
		LF	,ZQULID(X2)
		GENREL
		LF	,ZQULID(X2)
		AOS	YQRELR	; ASSUMES QRELI2=QRELID+1
		GENREL
		EXCH	XZHE,YCAZHE
	FI
	L	YRELST
	ST	YCASM
	LI	QRELST
	ST	YQRELR
	ST	YGAP	;[13] TO PREPARE FOR USE OF GENABS
	HLRZ	YCAZMP	; SYMBOL TABLE(ZSD) POINTER
	LF	X2,ZHETYP(XZHE)
	SF	X2,ZSMTYP(X0)

		;[13] OUTPUT ZERO AND NOT THE BASE ADDRESS OF THE SYMBOL TABLE
		; IF ZSD-POINTER = 0
	IF
		TRNE	X0,-1
	THEN
		GENABS
	ELSE
		GENREL
	FI

	LI	QRELST
	ST	YQRELL
	HRRZ	X2,YCAQND
	SETZ	X1,
	IF	IFOFF	YSWD
	THEN	; OUTPUT POINTERS TO SYMBOL TABLE
		WHILE	CAML	X2,YDCSTP
		DO	; GET A POINTER
			LF	,ZMPZSD(X2)
			IF	SKIPE	X1
			THEN	;ODD POINTER
				HRL	X1,
			ELSE	; OUTPUT TWO POINTERS
				ADD	X1
				GENREL
				SETZ	X1,
			FI
			STEP	X2,ZMP
		OD
	FI
	IF	SKIPN	X1
	THEN	;OUTPUT LAST POINTER
		SETZM	YQRELR
		L	X1
		GENREL
		SETZM	YQRELL
	ELSE
		SETZM	YQRELR
		SETZM	YQRELL
		SETZ
		GENREL
	FI
	LI	QRELPT
	ST	YQRELT
	EXCH	X3,YQRELR
	LI	X5,(X6)
	L	X6,YRELPT	;REMEMBER WHERE IN PROTOTYPE SECTION
	L	X2,YCAQND
;--- OUTPUT MAPS TO PROTOTYPE STREAM ---
	LI	QRELPT	; OUTPUT PROTOTYPES TO PROTOTYPE STREAM
	ST	YQRELT
	ST	YGAP
	ST	YQRELR
LOOP
	HRLI	X5,-ZMP%S
	ASSERT<RIGHTHALF(ZMPZMP)>
	ADDM	X6,OFFSET(ZMPZMP)(X2)
	IF	CAMN	X6,YRELPT
	THEN	; NOT FIRST MAP IN VECTOR
		L	(X5)
		GENREL
	ELSE
		SETZM	(X5)
		SUB	X5,[1,,1]
	FI
	WHILE	INCR	X5,TRUE
	DO
		L	(X5)
		GENABS
	OD
	L	X5,X2
	STEP	X2,ZMP
AS
	ASSERT<
		CAMLE	X2,YDCSTP
		GOTO	FALSE
		WHENNOT	X2,ZMP
		RFAIL	ZMP EXPECTED AT X2
		WHENNOT	X2,ZMP
		GOTO	FALSE
	>
	CAMG	X2,YDCSTP
	GOTO	TRUE
SA

	UNSTK	YQRELR
	LF(XFIX)ZHEFIX(XZHE)

IF		;--CLASS OR PREFIXED BLOCK --
	LF(X4)	ZHETYP(XZHE)
	CAIE	X4,QCLASB
	CAIN	X4,QPBLOCK
	GOTO	TRUE
THEN
	;OUTPUT ANY VIRTUAL DESCRIPTORS (STARTING WITH THE HIGHEST INDEX)
	LF(X3)	ZHBVRT(XZHE)	;NUMBER OF VIRTUALS
	WHILE
		SOJGE	X3,TRUE	;VIRTUAL INDEXES START AT 0
	DO
		EXEC	CAEBVM	;FIND THE MATCH IF ANY
		IF
			SKIPN	X2,YCAMTC
		THEN			;WE HAD A MATCH
			LF()	ZQUIND(X2)	;LABEL,SWITCH,PROC: FIXUP IN ZQUIND
			OP	(HRLZI	XWAC1,)
			GENFIX
		ELSE
			L	[RTSERR	QVIRTE]
			GENABS
		FI
		STEP	X2,ZQU
	OD


	;NOTE THAT THE PROTOTYPE IS DEVELOPED ONE WORD AT A TIME IN X0
	;AND OUTPUT. THE OFFSET IS USED TO MAKE THE EFFECTIVE ADDRESS
	;ZERO, AS IN ZCPZCP(,WOFS) (CHECK GENERATED CODE IN OCTAL).

WOFS==-4
	CHKOFS	<ZCPZCP>
	LF(X1)	ZHBZHB(XZHE)
	IF
		JUMPN	X1,TRUE
	THEN
		LF	X1,ZHBZQU(X1)
		LF(X1)	ZQUIND(X1)	;FIXUP OF PREFIX MUST BE ACCESSED THROUGH ZQU
		WSF(X1)	ZCPZCP(,-WOFS)	;(OR ZERO) TO X0
		GENFIX
	ELSE	
		SETZ
		GENABS
	FI
	NEXTWORD
	CHKOFS	<ZCPSTA,ZCPKDP>
	LI	X1,3(XFIX)	;FIXUP FOR 'STATEMENTS'
	IFON	ZHBKDP(XZHE)
	SETONA	ZCPKDP(X1)
	L	X1
	GENFIX

	NEXTWORD
	CHKOFS	<ZCPIEA>
	LI	4(XFIX)
	GENFIX

	NEXTWORD
	CHKOFS	<ZCPSBL,ZCPPRL>
	SETZ		;PREFIX LEVEL
	L	X1,XZHE
	LOOP
		LF(X1)	ZHBZHB(X1)
	AS
		JUMPE	X1,FALSE
		LF	X3,ZHBNRP(X1)
		JUMPE	X3,.+2
		SETONA	ZPCPAR(XP1)
		AOJA	TRUE
	SA
	LF(X1)	ZHBSBL(XZHE)	;
	MOVN	X1,X1
	SF(X1)	ZCPSBL(,-WOFS)
	GENABS
FI;--- CLASS OR PREFIXED BLOCK ---
;--- COMMON PART (ZPR) ---

	CAIN	X4,QPROCB
	L	XZHE,YCAZHE	; RESET TO ZHE FOR PROCEDURE
	L	X1,XFIX
	LI	X2,QRELPT
	EXCH	X2,YQREL
	DEFIX		;DEFINE FIXUP FOR THE PROTOTYPE

	EXCH	X2,YQREL
WOFS==0
	CHKOFS	<ZPRBLE,ZPRMAP>
	SF(X6)	ZPRMAP(,-WOFS)	;LINK TO MAP
	LF(X1)	ZHELEN(XZHE)
	SF(X1)	ZPRBLE(,-WOFS)
	EXCH	X2,YQRELR
	GENREL
	EXCH	X2,YQRELR	; RESTORE QRELCN

	NEXTWORD
	CHKOFS	<ZPREBL,ZPRSYM>
	LF(X1)	ZHEDLV(XZHE)
	SF(X1)	ZPREBL(,-WOFS)
	LI	X2,QRELST
	EXCH	X2,YQRELR
	HRR	YCASM
	GENREL
	EXCH	X2,YQRELR
IF		;NOT A SUBBLOCK
	CAIN	X4,QUBLOCK
THEN
		;TREAT ZPC PART
	NEXTWORD
	CHKOFS	<ZPCNRP,ZPCDLE>
	LF()	ZHBSZD(XZHE)
	ADDI	2	; ACCOUNT FOR OVERHEAD
	ASSERT <RIGHTHALF ZPCDLE>
	LF(X1)	ZHBNRP(XZHE)
	JUMPE	X1,.+2
	SETONA	ZPCPAR(XP1)
	SF(X1)	ZPCNRP(,-WOFS)
	GENABS

	NEXTWORD
	CHKOFS	<ZPCDEC>
	LI	2(XFIX)
	HLL	XP1	; PARAMETER PRESENT BIT IN CLASS PROTOTYPE
	GENFIX

;--- FORMAL DESCRIPTORS ---

	EXEC	CAFQX2
	WHILE
		RECTYPE(X2) IS ZQU
	DO
	IF		;A PARAMETER
		LF(X1)	ZQUMOD(X2)
		CAIGE	X1,QVIRTUAL
		CAIG	X1,QDECLARED
	THEN		;FORM A DESCRIPTOR IN X3
		SETZ	X3,
		;TYPE, MODE,KIND
		LF()	ZQUTMK(X2)
		SF()	ZFPTMK(,X3)
		ASSERT	<RIGHTHALF ZFPOFS>
		LF()	ZQUIND(X2)
		HLL	X3
		GENABS
		IF		;TYPE REF (ASSUME LEFT HALF)
			LF()	ZTDTYP(,X3)
			CAIE	QREF
		THEN
			LF(X1)	ZQUZQU(X2)	;[17] ZHB of qualif. class
			LF(X3)	ZHBZQU(X2)	;[17] Corresp. ZQU
			IF	;[17] System class
				IFOFF	ZQUSYS(X3)
			THEN	;Use 18 bits for fixup
				HRRZ	OFFSET(ZHEFIX)(X1)
			ELSE	;Use normal field
				LF()	ZHEFIX(X1)
			FI	;[17]
			GENFIX
		FI
	FI
	STEP	X2,ZQU
	OD;
FI;

;--- PROTOTYPE FINISHED ---

	LI	QRELCD		;RESTORE DEFAULT LOCATION COUNTER
	ST	YGAP
	ST	YQRELT
	L	X3,YDCSTP	;SAVE YDCSTP IN CASE OF A CLASS BLOCK
	EXEC	CAUS
	L	X1,YCAZHE
	LF()	ZHETYP(X1)
	IF	CAIE	QCLASB
	THEN
		ST	X3,YDCSTP
	ELSE
	IF	CAIE	QPROCB
	THEN
		ASSERT<	WHENNOT	X1,ZHB
			RFAIL	ZHB EXPECTED CAEB
		>
		LF	X3,ZHBZE(X1)
		ZF	ZHBZE(X1)	; RESET ZHE POINTER
		ST	X3,YDCSTP
	FI
	FI
	SETZM	@YDCSTP
	RETURN
	EPROC ;--- CAEB ---
COMMENT;	===ROUTINE CAEBVM===
PURPOSE:	TO FIND THE LAST VIRTUAL MATCH CORRESPONDING TO
		VIRTUAL INDEX (X3) IN A CLASS WITH POSSIBLE PREFIX
		CHAIN
ENTRY:		EXEC CAEBVM
		CALLED RECURSIVELY BY ITSELF THROUGH THE POINT CAEBV.
EXIT:		RETURN
;

CAEBVM:	PROC
	SETZM	YCAMTC
	SETZM	YCALID
CAEBV.:	STACK	XZHE
	LF(XZHE)ZHBZHB(XZHE)	;PREFIX?
	JUMPE	XZHE,.+2
	EXEC	CAEBV.	;FIND NEXT PREFIX
	UNSTK	XZHE
	STEP	XZHE,ZHB,X2	;X2 :- NEXT ZQU
	WHILE
		RECTYPE(X2) IS ZQU
	DO
	IF
		LF()	ZQUMOD(X2)
		CAIE	QVIRTUAL
	THEN		;SPEC FOR THIS VIRTUAL OR MATCH FOR ANOTHER?
		LF()	ZQUNSB(X2)	;A MATCH HAS ZQUNSB > 0
		IF
			JUMPE	TRUE
		THEN		;(SPEC)
			LF()	ZQUIND(X2)
			IF
				CAIE	(X3)
			THEN		;SPEC FOR THIS VIRTUAL FOUND
				LF()	ZQULID(X2)
				ST	YCALID
			FI
		ELSE		;MATCH?
			LF()	ZQULID(X2)
			IF
				CAME	YCALID
			THEN
				ST	X2,YCAMTC
			FI
		FI
	FI
		STEP	X2,ZQU
	OD;
	RETURN
	EPROC
	SUBTTL	CA DISPATCH TABLE

CAEN:	L	XZHE,YZHET
	GOTO	@.-SYMBL2(XCUR)
DEFINE	X(A,B,C,D)	<
	IFL <SYMBL2-B>, <
	IFG <SYMBL3-B>, <
	A'.>>>
	SYMB(6,0,X)

ILSYM.:	RFAIL	 ILLEGAL SYMBOL (CA)
	NEXT
	SUBTTL	CAMM (MAKE MAP OF BLOCK)

COMMENT;	=== ROUTINE CAMM ===
PURPOSE:	CONVERT A SEQUENCE OF ZQU RECORDS TO A ZMP RECORD
		(GARBAGE COLLECTOR MAP).
		Note that text variables are assumed to follow
		"other" variables. The count of text variables
		is included in the count for other variables
		to simplify initialisation of (reduced) subblocks.
		For the benefit of the garbage collector, text variables
		are also accounted for separately. The count, in each
		instance, is negated and represents the number of words
		rather than the number of variables. The format of each
		descriptor word is suitable for loop counting.
INPUT:		XZHE POINTS TO ZHE OR ZHB OF THE ZQU LIST
		X6 POINTS TO WHERE THE MAP IS PUT
ENTRY:		EXEC CAMM
EXIT:		RETURN
;

CAMM:	PROC
	SAVE	<X2,X3,X4,X5>
	XMP=X2	;BASE OF ZMP RECORD IN REGISTERS
	XOV=X3	;'OTHER' VARIABLES
	XRV=X4	;REF AND ARRAY
	XTX=X5	;TEXT
	SETZB	X2,X3
	IF	CAMN	XZHE,YCAZHE	; PROC ZHE?
		GOTO	FALSE
		LF	,ZHETYP(XZHE)
		CAIE	QPROCB
		GOTO	FALSE
		IFOFF	YSWD
	THEN
		; OUTPUT PROC PARMS
		L	X3,YCAZHE
		HRLI	X3,ZHB%S(X3)
	FI
	EXEC	CAFQX2	;FIRST ZQU TO X2
	HLL	X2,X3
	IFON	YSWD
	EXEC	O2SM	; OUTPUT SYMBOLS AND RETURN ZSD POINTER IN YO2ZSD
	SETZB	XOV,XRV
	SETZ	XTX,
WHILE
	RECTYPE(X2) IS ZQU
DO
	IFNEQF	X2,ZQUMOD,QDECLARED	;DECLARED VARIABLE?
	GOTO	L1
	LF(X1)	ZQUIND(X2)
	LF()	ZQUKND(X2)	;KIND
	CAIN	QARRAY
	GOTO	CAMM.R
	CAIE	QSIMPLE
	GOTO	L1
    ;---SIMPLE VARIABLE, CHECK TYPE ---
	LF()	ZQUTYP(X2)
	CAIN	QREF
	GOTO	CAMM.R
	CAIN	QTEXT
	GOTO	CAMM.T
	CAIN	QLABEL
	GOTO	L1
    ;-- SIMPLE, 'OTHER' VARIABLE ---
	JUMPN	XOV,.+2
	SF(X1)	ZMPDOV(,XMP)
	SUB	XOV,[1,,0]	;NEGATIVE COUNT IN LEFT HALF
	CAIN	QLREAL
	SUB	XOV,[1,,0]	; TWO WORDS FOR LONG REAL
	GOTO	L1

CAMM.R:	;--- REF OR ARRAY ---
	JUMPN	XRV,.+2
	SF(X1)	ZMPDRV(,XMP)
	SUB	XRV,[1,,0]	;NEGATIVE COUNT IN LEFT HALF
	GOTO	L1

CAMM.T:	;--- TEXT VARIABLE ---
	JUMPN	XTX,.+2
	SF(X1)	ZMPDTX(,XMP)
	SUB	XTX,[2,,0]	;TEXT VARIABLE HAS TWO WORDS
L1():	STEP	X2,ZQU
OD;
	; SET YCAQND
	WHILE	LF	X1,ZDETYP(X2)
		SKIPN	X1
	DO
		XCT	CAMM.S(X1)	; STEP RECORD
	OD
	IF	SKIPE	XOV
	THEN	;NO OTHER VARIABLES
		L	XOV,XTX
	ELSE
		HLLZ	XTX
		ADD	XOV,
	FI
	ST	X2,YCAQND
	HLLZ	XMP,YO2ZSD
	STD	XMP,(X6)
	STD	XMP+2,2(X6)
CAMM.O:	RETURN
		; !!! ZHE%V=1,ZHB%V=2,ZQU%V=4
	EPROC
CAMM.S:	RFAIL	CAMMS
	STEP	X2,ZHE
	STEP	X2,ZHB
	RFAIL	CAMMS
	STEP	X2,ZQU
	SUBTTL	CACO

COMMENT;	=== ROUTINE CACO ===
PURPOSE:	COPIES ZHB OF THE CLASS THAT IS POINTED TO BY ZHBZHB(XZHE),
		THEN COPIES ITS ZQU LIST. THE SAME IS DONE FOR EACH
		PREFIX. THE ZHBZHB CHAIN IS UPDATED TO POINT TO THE COPIED
		CLASS ETC. ZQUZHE ENTRIES ARE CHANGED TO POINT TO
		THE CONNECTION ZHB.
ENTRY:		EXEC CACO
EXIT:		RETURN
USES:		CADISP,M2CO,O2AB,O2LN6,CAUSTD
;


CACO:	PROC
	SAVE	<X2,X3,X4,X5,X6>
	SETZ	X6,
	ASSERT<WHENNOT	XZHE,ZHB
		RFAIL	CACO PARAMETER ERROR
	>
	L	X3,XZHE
	L	X4,YDCSTP
	CAML	X4,YDCSTO
	EXEC	M2CO	; MORE CORE NEEDED
	LI	X1,-1(X4)
	LF	,ZHBZHB(X3)
	CAML	YDCSTB
	CAML	YDCSTP
	BRANCH	O2AB	; NO RECOVERY IF INSPECTED CLASS UNKNOWN
	WHILE
		LF(X5)	ZHBZHB(X3)
		JUMPN	X5,TRUE
	DO
		ASSERT<	WHENNOT	X5,ZHB
			RFAIL	ZHBZHB LINKS ERROR CACO
		>
		STEP	X1,ZHB
		STEP	X5,ZHB,X2
		;/COPY ZHB/;
		HRLI	(X5)
		HRRI	(X4)
		BLT	(X1)
		SKIPE	X6
		SF	X4,ZHBZHB(X6)	;INSERT PREFIX OF COPY
		L	X6,X4
		STEP	X4,ZHB
		CAML	X4,YDCSTO
		EXEC	M2CO
		WHILE
			RECTYPE(X2) IS ZQU
		DO
			STEP	X1,ZQU
			;/COPY ZQU/;
			HRLI	(X2)
			HRRI	(X4)
			BLT	(X1)
			SF(XZHE)ZQUZHE(X4)	;NEW ZQUZHE
			SETON	ZQUIS(X4)
			LI	X4,1(X1)
			STEP	X2,ZQU
			CAML	X4,YDCSTO
			EXEC	M2CO
		OD
		L	X3,X5
	OD
	L	YDCSTP
	CAMN	X4
	SETZ
	SF	,ZHBZHB(XZHE)
	IFON	YSWI
	EXEC	O2LN6
	SETZM	(X4)
	EXEC	CADISP	;DISPLAY PREFIXES, THEN CLASS, THEN CONNECTION
	ASSERT<	CAML	X4,YDCSTO
	RFAIL	DECL. STACK OVERFLOW
	>
	ST	X4,YDCSTP
	EXEC	CAUSTD
	RETURN
	EPROC
	SUBTTL	CAPL,CAUS

COMMENT;	=== ROUTINE CAPL ===
PURPOSE:	COMPUTE PREFIX LEVEL OF CLASS TO WHOSE ZHB RECORD XZHE POINTS,
		AND COMPILE:  MOVEI XSAC,prefix level
ENTRY:		EXEC	CAPL
NORMAL EXIT:	RETURN
INPUT:		XZHE, POINTS TO ZHB OF CLASS
USED ROUTINE:	O2GA
;
CAPL:	PROC
	SETZ			;PREFIX LEVEL TO X0
	L	X1,XZHE
	LOOP
		LF(X1)	ZHBZHB(X1)
	AS
		JUMPE	X1,FALSE
		AOJA	TRUE
	SA
	OP	(MOVEI	XSAC,)
	GENABS
	RETURN
	EPROC


COMMENT;	=== ROUTINE CAUS ===

PURPOSE:	STACK DOWN BLOCK STACK, DECLARATION STACK
		AND REDECLARATION STACK.
		UPDATE XZHE AND YZHET.
CALL:		EXEC	CAUS
EXIT:		RETURN
;

CAUS:	PROC
	L	X1,YBKSTP	;STACK DOWN BLOCK STACK
	POP	X1,X0
	HRRZM	YDCSTP
	HLRZM	YRDSTP
	HRRZ	(X1)
	ST	YZHET
	ST	XZHE
	ST	X1,YBKSTP
	RETURN
	EPROC
	SUBTTL	CARDX3,CAFQX2

;--- SMALL AUXILIARY ROUTINES ---

CARDX3:	;--- FORMS REDECLARATION STACK POINTER IN X3 ---
	HRRZ	X3,YRDSTP
	SUB	X3,YRDSTO
	HRL	X3,X3
	HRR	X3,YRDSTP
	RETURN

CAFQX2:	;--- MAKES X2 POINT TO FIRST ZQU RECORD ---
	STEP	XZHE,ZHE,X2
	WHEN	XZHE,ZHB
	STEP	XZHE,ZHB,X2
	RETURN

	SUBTTL	CADS (DISPLAY)

COMMENT;	=== ROUTINE CADS ===
PURPOSE:	DISPLAY ZQU LIST POINTED TO BY XZHE INTO THE DICTIONARY,
		PUSHING OLD DECLARATIONS INTO REDECLARATION STACK.
ENTRY:		EXEC CADS
EXIT:		RETURN
;

CADS:	PROC
	SAVE	<X2,X3>
	IFN	QDEBUG,<
		IF	IFOFF	SCADB5
		THEN
			EXEC	O2DB1,<<[020000,,0]>>	; NEW LINE ON DEBUG FILE
			HRL	XZHE
			EXEC	O2DB3,<<[610000,,'DIS']>,X0>
		FI
	>
	EXEC	CAFQX2	;STEP X2 TO ZQU RECORD
	EXEC	CARDX3	;FORM REDECL STACK POINTER IN X3

WHILE
	RECTYPE(X2) IS ZQU
DO
	LF(X1)	ZQULID(X2)
	JUMPE	X1,CADS.2
	IFON	ZQUIVA(X2)	;[40]
	GOTO	CADS.2		;DONT DISPLAY IF INVISIBLE[40]
	IFN	QDEBUG,<
		IF	IFOFF	SCADB5
		THEN	; DEBUG OUTPUT
			HRLI	X1,300000
			EXEC	O2DB2,<X1>
			HRRZ	X1,X1
		FI
	>
	WLF()	ZDCZDC(X1,YDICTB)
	JUMPE	CADS.1
	PUSH	X3,		;SAVE OLD DECL
	SF(X3)	ZDCZDC(X1,YDICTB)	;AND REMEMBER WHERE.
CADS.1:	SF(X2)	ZDCZQU(X1,YDICTB)	;STORE NEW ZQU POINTER
CADS.2:	STEP	X2,ZQU
OD;
	ST	X3,YRDSTP
	RETURN
	EPROC
	SUBTTL	CAUD (UNDISPLAY)

COMMENT;	=== ROUTINE CAUD ===
PURPOSE:	UNDISPLAY ZQU LIST STARTED BY ZHE OR ZHB RECORD POINTED TO
		BY XZHE, RESTORING REDECLARED QUANTITIES.
ENTRY:		EXEC CAUD
EXIT:		RETURN
;

CAUD:	PROC
	SAVE	X2
	IFN	QDEBUG,<
		IF	IFOFF	SCADB5
		THEN
			EXEC	O2DB1,<<[020000,,0]>>	; NEW LINE ON DEBUG FILE
			HRL	XZHE
			EXEC	O2DB3,<<[610000,,'UDS']>,X0>
		FI
	>
	EXEC	CAFQX2		;GET FIRST ZQU TO X2

WHILE
	RECTYPE(X2) IS ZQU
DO
	LF(X1)	ZQULID(X2)
	IF
		IFOFF	ZQUIVA(X2)	;[40] Not displayed if invisible
		SKIPN	X1
	THEN
	IFN	QDEBUG,<
		IF	IFOFF	SCADB5
		THEN	; DEBUG OUTPUT
			HRLI	X1,300000
			EXEC	O2DB2,<X1>
			HRRZ	X1,X1
		FI
	>
	LF()	ZDCZDC(X1,YDICTB)	;ANY REDECLARATION FOR THIS QUANTITY?
	JUMPE	.+2		;IF NOT, STORE ZERO IN DICTIONARY,
	L	@		;OTHERWISE RESTORE OLD DECLARATION
	WSF()	ZDCZDC(X1,YDICTB)
	FI
	STEP	X2,ZQU
OD;
	RETURN
	EPROC
	SUBTTL	CADISP,CAUNDI

CADISP:	PROC	;DISPLAY PREFIXES, THEN THE CLASS OR PREFIXED BLOCK
	STACK	XZHE
	LF(XZHE)ZHBZHB(XZHE)
	JUMPE	XZHE,.+2
	EXEC	CADISP	;RECURSIVE CALL
	UNSTK	XZHE
	DISPLAY
	RETURN
	EPROC


CAUNDI:	PROC	;UNDISPLAY A BLOCK AND POSSIBLE PREFIXES
		;WORKS ALSO FOR CONNECTION BLOCK
	SAVE	<XZHE>
	IF
		RECTYPE(XZHE) IS ZHE
	THEN
		UNDISPLAY
	ELSE
		LOOP
			UNDISPLAY
			LF(XZHE)ZHBZHB(XZHE)
		AS
			JUMPN	XZHE,TRUE
		SA
	FI
	RETURN
	EPROC
CAUSTD:	PROC	; UPDATE ZHBSTD ON ENTRY AND EXIT TO
			; FOR STATMT, INSPECTION AND UNREDUCED SUBBLOCK
		SAVE	<X2,X3>
		L	X2,YZHET
		L	X3,YZHBXC
		ASSERT<	WHENNOT	X3,ZHB
			RFAIL NOT ZHB AT YZHBXCB
		>
		LF	X1,ZHEDLV(X2)	; NEW TOP
		MOVN	X1,X1
		ADDI	X1,1
		LF	,ZHBSTD(X3)
		LF	X2,ZHBSZD(X3)
		CAIG	X2,(X1)
		SF	X1,ZHBSZD(X3)
		SF	X1,ZHBSTD(X3)
		CAIL	X1,QMAXDIS
		ERROR2	50,DISPLAY SIZE OVERFLOW
		RETURN
		EPROC
	SUBTTL	CAUNPR	[40]


COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

FUNCTION:	Make all protected attributes accessible and hide
		hidden attributes. If FLAG is zero then check
		own HIDDEN specifications.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


CAUNPR:	PROC	<FLAG>
	SAVE	<X1,X2,X3,X4,XZHE>
	EXEC	CAUNP1
	EXEC	CAUNP2
	WHEN	X2,ZQU
	SKIPE	FLAG
	SKIPA
	EXEC	CAUNP3
	RETURN
	EPROC

CAUNP1:	PROC
	SAVE	XZHE
	LF	XZHE,ZHBZHB(XZHE)
	IF	SKIPN	XZHE
	THEN
		EXEC	CAUNP1
		EXEC	CAUNP2
		WHEN	X2,ZQU
		EXEC	CAUNP4
	FI
	RETURN
	EPROC


CAUNP2:	PROC
	STEP	XZHE,ZHB,X2
	WHILE
		WHENNOT	X2,ZQU
	DO
		IF	IFOFF	ZQUIVA(X2)
		THEN
			IFOFF	ZQUPTD(X2)
			RETURN	;X2 POINTS TO FIRST HIDDEN SPEC
			SETOFF	ZQUIVA(X2)
		FI
		STEP	X2,ZQU
	OD
	RETURN
	EPROC


CAUNP3:	PROC
	LI	X3,0
	WHILE
		EXEC	CAUNP5
		SKIPN	X3
	DO
		IF	SKIPN	X4
		THEN
			SETON	ZQUTPT(X4)
		FI
		IF
			IFON	ZQUNOT(X2)
			GOTO	[JUMPE	X4,TRUE
				GOTO	FALSE]
			JUMPN	X4,TRUE
		THEN
			IFOFF	ZQUPTD(X3)
			EXEC	CAE421
		FI
	OD
	LOOP
		IFOFF	ZQUTPT(X2)
		EXEC	CAE422
		SETOFF	ZQUTPT(X2)
		STEP	X2,ZQU
	AS
		WHEN	X2,ZQU
		GOTO	TRUE
	SA
	RETURN
	EPROC


CAUNP4:	PROC
	LI	X3,0
	WHILE
		EXEC	CAUNP5
		SKIPN	X3
	DO
		IF
			IFON	ZQUNOT(X2)
			GOTO	[JUMPE	X4,TRUE
				GOTO	FALSE]
			JUMPN	X4,TRUE
		THEN	;HIDE
			IF	IFOFF	ZQUPTD(X3)	;ERROR ALREADY GENERATED
			THEN
				SETON	ZQUIVA(X3)
			FI
		FI
	OD
	RETURN
	EPROC


CAUNP5:	PROC
	IF	SKIPE	X3
	THEN
		STEP	XZHE,ZHB,X3
	ELSE
		STEP	X3,ZQU
	FI
	IF
		WHEN	X3,ZQU
	THEN
		LI	X3,0
		LF	XZHE,ZHBZHB(XZHE)
		JUMPN	XZHE,CAUNP5
		RETURN
	FI
	IFON	ZQUIVA(X3)
	GOTO	CAUNP5
	L	X4,X2
	LF	X1,ZQULID(X3)
	WHILE
		WHENNOT	X4,ZQU
	DO
		LF	,ZQULID(X4)
		CAMN	X1
		RETURN
		STEP	X4,ZQU
	OD
	LI	X4,0
	RETURN
	EPROC


CAE421:	PROC
	LF	,ZQULNE(X2)
	SKIPE	X4
	LF	,ZQULNE(X4)
	ST	YELIN1
	ST	YELIN2
	LF	X1,ZQULID(X3)
	ERRI1	QE,421	;Attribute XXXX hidden but not protected
	RETURN
	EPROC


CAE422:	PROC
	LF	,ZQULNE(X2)
	ST	YELIN1
	ST	YELIN2
	LF	X1,ZQULID(X2)
	ERRI1	QE,422	;No attribute XXXX visible
	RETURN
	EPROC
	SUBTTL	CAPROT [40]


COMMENT;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

FUNCTION:	Make all protected attributes in this class and
		its prefix classes inaccessible.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


CAPROT:	PROC
	WHENNOT	XZHE,ZHB
	RETURN
	SAVE	<X1,XZHE>
	STEP	XZHE,ZHB,X1
	WHILE
		WHENNOT	X1,ZQU
	DO
		IF	IFOFF	ZQUPTD(X1)
		THEN
			SETON	ZQUIVA(X1)
		FI
		STEP	X1,ZQU
	OD
	LF	XZHE,ZHBZHB(XZHE)
	SKIPE	XZHE
	EXEC	CAPROT
	RETURN
	EPROC
	SUBTTL	BBLK, --- BEGIN SUBBLOCK ---

BBLK.:	COMMENT; --- CODE FOR BEGIN OF SUBBLOCK -
	READ DECLARATION LIST FROM DF1,
	EMIT CODE FOR BLOCK ENTRY
;

	EXEC CARL	;READ QUANTS FOR BLOCK INTO DECLARATION STACK

	ASSERT <WHENNOT	(XZHE,ZHE)
		RFAIL	ZHE RECORD EXPECTED
	>
	IF	LI	X2,ZHE%S(XZHE)
		CAME	X2,YDCSTP
	THEN	;NO ZQUS IN LIST: INSERT DUMMY ZQU
		SETZM	X0
		SETZM	X1
		STD	(X2)
		STD	2(X2)
		LI	ZQU%V
		SF	,ZDETYP(X2)
		LI	ZQU%S(X2)
		ST	YDCSTP
	FI
	LF()	ZHETYP(XZHE)
	
	ASSERT <CAIL	QRBLOCK	;ASSUME QUBLOCK=QRBLOCK+1
		CAILE	QUBLOCK
		RFAIL	SUBBLOCK EXPECTED
	>
	IF		;UNREDUCED SUBBLOCK
		CAIE	QUBLOCK
	THEN	
		EXEC	O2LN1
		LF()	ZHEFIX(XZHE)	;FIXUP FOR SUBBLOCK PROTOTYPE
		OP	(MOVEI	XSAC,)	;/ MOVEI XSAC,prototype /;

		GENFIX			;/ PUSHJ XPDP,CSSB	/;
		EXEC	CAUSTD

		GPUSHJ	CSSB
	ELSE
		LF()	ZHEBNM(XZHE)	;BLOCK STATE NUMBER
		OP	(MOVEI	XSAC,)
		GENABS
		IF	CAMN	XZHE,YZHBXC
		THEN	; CURRENT BLOCK NOT ADDRESSABLE BY XCB?
			L	X1,YBKSTP
			WHILE	LF	,ZHETYP(XZHE)
				CAIE	QFOR	; SKIP FOR STATEMENTS
			DO
				POP	X1,XZHE
			OD
			LF	,ZHEDLV(XZHE)
			L	X1,YZHBXCB
			LF	X1,ZHEDLV(X1)
			CAMN	X1
			GOTO	FALSE	; OUT FROM IF-THEN
			LF	,ZHEDLV(XZHE)
			OP	(HRL	XSAC,(XCB))
			GENABS
		FI
		GPUSHJ	CSER
		IFON	YSWI
		EXEC	O2LN5
	FI
	EXEC	O2DFTE	;[6]	OUTPUT TENTATIVE FIXUP IF ANY
	NEXT
	SUBTTL	BPROG, DEBUG, DO

BPROG.:	ASSERT<	L	YDCSTP
		CAME	YDCSTB
		RFAIL	BPROG NOT FIRST SYMBOL IN IC1
	>
; READ STANDARD QUANTITIES USED IN THIS PROGRAM
	EXEC	CARL
	LI	2
	SF	,ZHEEBL(XZHE)
; ALLOCATE OUTERMOST BLOCK
	IF	IFON	YSWCE
	THEN	; OUTERMOST BLOCK IS REDUCED SUBBLOCK
		L	X3,YMPSIZ
		SF	X3,ZHELEN(XZHE)
		L	X2,YRELCD
		ADDI	X2,<QMAXDIS-1>
		MOVSI	<<QZDR>B<%ZDNTYP+↑D18>>
		GENABS	; ZDN WORD
		LI	QMAXDIS+1
		GENABS	; ZDR RECORD LENGTH
		LOOP	SETZ
			GENABS
		AS	CAME	X2,YRELCD
			GOTO	TRUE
		SA
		LI	2(X2)
		ST	YCABKB
		GENRLD	; DISPLAY ELEMENT
		SETZ
		GENABS	; RETAD-BLOCKAD ZERO IN  OUTERMOST BLOCK
		; BLOCK STARTS HERE
		L	X4,YRELCD
		HRLZI	X0,<1B<%ZDNDET+↑D18>+<QZPB>B<%ZDNTYP+↑D18>>	; ZBIBNM ZERO
		GENABS
		L	X2,YDCSTB
		LF	,ZHEFIX(X2)
		GENFIX	; FIRST ZBI WORD WITH PROTOTYPE ADDRESS
		LI	QMAXDIS-3
		SF	,ZHBSZD(X2)
		LOOP	SETZ
			GENABS
		AS	SOJG	X3,TRUE
		SA
		EXEC	O2LN1	; FIRST PROTOTYPE ENTRY
		EXEC	O2LN2	; FIRST ENTRY OF LINE TABLE FOR MODULE
	L	X3,YRELCD
	L	X2,[-8,,YSWRF]
	IF	SKIPE	(X2)
	THEN	; NO RUNSWITCH
		SETO	X3,
	ELSE
	LOOP
		L	(X2)
		GENABS
	AS	AOBJN	X2,TRUE
	SA
	FI
; GENERATE INITIALIZING SEQUENCE
	L	YRELCD	; SAVE ENTRY POINT
	ST	YCANTRY
	L	[JRST	1,1]
	ADD	YRELCD
	GENRLD
	L	[TDZA	1,1]
	GENABS
	L	[JRST	1,1]
	ADD	YRELCD
	GENRLD
	OPZ	(LI	XCB,)
	HRR	X4
	GENRLD
	OPZ	(JSP	16,)
	HRRI	OCSP
	GENFIX
	OPZ	(NOP)
	IF	SKIPL	X3
	THEN	; NO RUNSWITCH
		GENABS
	ELSE
		HRR	X3
		GENRLD
	FI
FI
	L	YDCSTB
	ST	YZHBXC
	LI	X1,QIDTXT
	LF	,ZDCZQU(X1,YDICTB)
	ASSERT<SKIPN	X0
		RFAIL	TEXT MISSING IN DICT
	>
	ST	YTEXTI
	L	X4,XZHE
	IF	SKIPN	XZHE,YDICTB+QIDSIN
	THEN
		ST	XZHE,YSYSI
		LF	XZHE,ZQUZQU(XZHE)
		LF	XZHE,ZQUZB(XZHE)
		HRR	X5,XZHE
	ASSERT<
	ELSE
		OUTSTR	[ASCIZ/SYSIN MISSING/]
	>
	FI
	IF	SKIPN	XZHE,YDICTB+QIDSUT
	THEN
		LF	XZHE,ZQUZQU(XZHE)
		LF	XZHE,ZQUZB(XZHE)
		HRL	X5,XZHE
	FI
	L	XZHE,X4
	IFON	YSWCE
	EXEC	CAUD
	HRR	XZHE,X5
	EXEC	CADISP
	HLR	XZHE,X5
	EXEC	CADISP
	L	XZHE,X4
	IFON	YSWCE
	EXEC	CADISP
	IF	SKIPN	X1,YDICTB+QIDSIM
	THEN
		LF	X1,ZQUZB(X1)
		STEP	X1,ZHB
		WHILE	LF	X2,ZQULID(X1)
			CAIN	X2,QIDPRO
		DO
			STEP	X1,ZQU
			ASSERT<
				CAML	X1,YDCSTO
				RFAIL	PROCESS ZQU NEVER FOUND
			>
		OD
		ST	X1,YPROCI
	ELSE
		OUTSTR	[ASCIZ/SIMULATION MISSING/]
	FI
	EXEC	CAUSTD
	LI	X2,QRELST
	EXCH	X2,YGAP
	GENABS
	EXCH	X2,YGAP
	NEXT

IFN QDEBUG,	<
	EXTERN	CADB
DEBUG.=	CADB
>
IFE QDEBUG,	<
DEBUG.=	ILSYM.
>


DO.:	;--- INSPECT <object expression> DO ---
	;READ ZHB AND POSSIBLE LABEL LIST.
	;COPY ZHB-ZQU LISTS OF INSPECTED CLASS AND ANY PREFIXES,
	;THEN DISPLAY CLASS (AFTER PREFIXES), THEN DISPLAY LABEL LIST.

	EXEC	CARL
	ASSERT<	WHENNOT	XZHE,ZHB
		RFAIL	DOZHB NOT FOUND
	>
	UNDISPLAY	;DEFER DISPLAY OF LABEL LIST
	L	X1,YORZQU
	SF	X1,ZHBZQU(XZHE)
	SETZM	YORZQU
	LF()	ZQUZB(X1)
	SF()	ZHBZHB(XZHE)
	LF	,ZHEDLV(XZHE)
	OP	(ST	XWAC1,(XCB))
	GENABS
	BRANCH	CACO
	SUBTTL	EBLK

EBLK.:	;--- END OF SUBBLOCK ---

ASSERT <WHENNOT	(XZHE,ZHE)
	RFAIL	ZHE RECORD EXPECTED
>
	LF()	ZHETYP(XZHE)
ASSERT <CAIL	QRBLOCK
	CAILE	QUBLOCK
	RFAIL	SUBBLOCK EXPECTED
>
IF
	CAIE	QUBLOCK
THEN

;--UNREDUCED SUBBLOCK

	QSADEA=1
	IFE QSADEA,<
	; OLD CODE, NO DEALLOCATION BEFORE GC
	LF()	ZHEDLV(XZHE)	;CODE TO CLEAR DISPLAY ENTRY
	OP	(SETZM	(XCB))
	GENABS
	>
	IFN	QSADEA,<
	QINLIN=0
	QSUBR=1
	IFG	QINLIN,<
	;DEALLOCATION DONE BY INLINE CODE
	L	[SETZ	XTAC,]
	GENABS
	LF	,ZHEDLV(XZHE)
	OP	(EXCH	XTAC,(XCB))
	GENABS	;CLEAR DISPLAY AND GET RECORD TO XTAC
	L	[LOWADR(XWAC2)]
	GENABS
	L	[CAMG	XTAC,YSADEA(XWAC2)]
	GENABS
	L	YRELCD
	ADDI	6
	OP	(JRST)
	EXEC	CGRD
	L	[HRRI	XSAC,1(XTAC)]
	GENABS
	L	[SETZM	(XTAC)]
	GENABS
	L	[HRL	XSAC,XTAC]
	GENABS
	L	[BLT	XSAC,@YSATOP(XWAC2)]
	GENABS
	L	[HRRZM	XTAC,YSATOP(XWAC2)]
	GENABS
	>
	IFG	QSUBR,<
	LF	,ZHEDLV(XZHE)
	OP	(MOVEI	XSAC,(XCB))
	GENABS
	GPUSHJ	CSEU
	>
	>
	EXEC	CAEB		;UNDISPLAY,OUTPUT PROTOTYPE AND MAP
	EXEC	CAUSTD
	NEXT

FI
;--REDUCED SUBBLOCK --
	IFON	YSWI
	EXEC	O2LN4
	UNDISPLAY

;--Make map of subblock
;--SQUEEZE OUT QUANTS, LEAVE ZMP RECORDS

	L	X6,XZHE
	EXEC	CAMM	;LEAVE POINTER TO END OF QUANTS IN YCAQND
	STEP	XZHE,ZMP
	L	X2,XZHE
	L	X1,YDCSTP	;DECL STACK TOP
	SUB	X1,YCAQND	;- END OF QUANTS => LENGTH OF CHUNK 
IF
	JUMPG	X1,TRUE		; TO MOVE, IF ANY
THEN
	HRL	X2,YCAQND	;FORM BLT WORD IN X2
	ADDI	X1,(XZHE)
	BLT	X2,(X1)		;MOVE IT
	SUB	X6,YCAQND	;-LENGTH OF SKIPPED DATA
	ADD	X6,YDCSTP	;DECREASE STACK POINTER
FI
	L	X3,YZHET	; WHERE THE MAP WAS JUST PUT
	EXEC	CAUS
	LF	X2,ZHEBNM(XZHE)
	ASH	X2,2
	SF	X2,ZMPZMP(X3)
	STEP	X6,ZMP
	SETZM	(X6)
	ST	X6,YDCSTP
; CODE TO UPDATE BLOCK STATE

	LF()	ZHEBNM(XZHE)
	OP	(MOVEI	XSAC,)
	GENABS
	IF	L	X1,YZHBXC
		LF	X1,ZHEDLV(X1)
		LF	,ZHEDLV(XZHE)
		CAME	X1
	THEN	; XCB POINTS TO BASE
		L	[$ZBIBNM(XCB)]
	ELSE
		OP	(L	XTAC,(XCB))
		GENABS
		L	[$ZBIBNM(XTAC)]
	FI
	GENWRD
	OP	(DPB	XSAC,)
	GENREL
	ASSERT<	LF	,ZHETYP(XZHE)
		CAIN	QFOR
		RFAIL	REDUCTION PAST FOR
		CAIN	QCLASB
		RFAIL	REDUCTION INTO CLASS
		CAIN	QINSPE
		RFAIL	REDUCTION PAST INSPECT
	>
	NEXT
	SUBTTL	EDCL, EDPB

EDCL.:	;--- END OF DECLARATIONS IN A CLASS

	COMMENT;	DEFINE FIXUP F+3, WHERE F IS BASE FIXUP OF CLASS.
			OUTPUT A CALL ON CPCD
;

	EXEC	CAPL		;COMPILE /MOVEI XSAC,prefix level/
	GJRST	CPCD
	LF(X1)	ZHEFIX(XZHE)	;DEFINE ZHEFIX+3 OF THIS CLASS
	ADDI	X1,3
	DEFIX
	NEXT


EDPB.:	;--- END DECLARATIONS IN A PREFIXED BLOCK

	COMMENT;	DEFINE FIXUP+5 OF PREFIXED BLOCK
			OUTPUT CALL ON CPPD
;

	GJRST	CPPD
	LF(X1)	ZHEFIX(XZHE)
	ADDI	X1,3
	DEFIX
	NEXT
	SUBTTL	ENDCL

ENDCL.:	COMMENT; --- END OF CLASS BODY ---
	GENERATE CLASS EXIT CODE. MAKE A TENTATIVE DEFINITION
	OF FIXUP F+5 FOR THE CLASS.
	UNDISPLAY CLASS ATTRIBUTES.
	OUTPUT PROTOTYPE AND MAP.
;
	EXEC	CPEND
	IF	SKIPE	X2
	THEN
		GJRST	CPE0
	FI
	LF(X2)	ZHEFIX(XZHE)
	EXEC	CAEB	;OUTPUT PROTOTYPE AND MAP, STACK DOWN BLOCK STACK
	LI	X1,5(X2)
	HRROS	YTENT		;TENTATIVE FIXUP DEFINITION (F+5)
	DEFIX
	NEXT
	SUBTTL	CPEND

CPEND:	;FIND OUT IF ANY PREFIX HAS AN EXPLICIT INNER AND COMPILE
	;A JUMP TO STATEMENTS AFTER INNER, OTHERWISE X2 IS 0 ON
	;RETURN.

	L	X1,XZHE
	LOOP
		LF(X2)	ZHBZHB(X1)	;PREFIX?
		JUMPE	X2,FALSE
		L	X1,X2
		IFON	ZHENOI(X1)	;IF NO INNER IN PREFIX, TRY NEXT PREFIX
		GOTO	TRUE
		LF	X2,ZHBZQU(X1)
		IF
			IFON	ZQUSYS(X2)	; SYSTEM PREFIX
			GOTO	FALSE
			IFON	ZHBEXT(X1)	;CHECK FOR EXTERNAL PREFIX
		THEN	;-- NORMAL PREFIX, COMPILE JRST TO INSTR AFTER INNER
			;-- IN PREFIX --
			LF(X2)	ZQUIND(X2)
			LI	4(X2)
			OP	(JRST)
			GENFIX
		ELSE	;-- PREFIX EXTERNAL, COMPILE JRST THROUGH PROTOTYPE --
			LF(X2)	ZQUIND(X2)
			LI	(X2)
			OP	(MOVEI	XSAC,)
			GENFIX
			L	[JRST	@OFFSET(ZCPIEA)(XSAC)]
			GENABS
		FI
	AS	SA
	RETURN
	SUBTTL	ENDDO,ENDFO

ENDDO.:	;--- END OF DO CLAUSE IN INSPECTION ---
; CLEAR DISPLAY ELEMENT
	OPZ	(SETZ	XWAC1,)
	GENABS
	LF	,ZHEDLV(XZHE)
	OP	(EXCH	XWAC1,(XCB))
	GENABS
	LF(X2)	ZHEFIX(XZHE)
	ST	X2,YORFX
	LI	3(X2)		;COMPILE JRST TO END OF
	OP	(JRST)		;INSPECTION
	GENFIX
	LI	X1,2(X2)	;DEFINE AND RELEASE FIXUP F+2
	DEFIX
	LI	X1,2(X2)
	CLFIX
	EXEC	O2AF	; ALLOCATE IT AGAIN FOR NEXT WHEN CLAUSE
	LF()	ZHBZQU(XZHE)
	ST	YORZQU		;SAVE ZQU OF QUALIFYING CLASS
	LF()	ZHBZHB(XZHE)	;AND ZHB OF DECLARING CLASS
	ST	YORZHB
	EXEC	CAUNDI		;UNDISPLAY, FOLLOWING ZHB CHAIN,
	IFON	YSWI
	EXEC	O2LN4
	LI	X1,1(X2)
	CLFIX	; CLEAR AND REALLOCATE FIX FOR LINE TABLE
	LI	X1,1(X2)
	EXEC	O2AF
	EXEC	CAUS		;THEN UNSTACK THE CONNECTION BLOCK
	NEXT


ENDFO.:	;--- END OF FOR STATEMENT ---
	;COMPILE CODE TO GO BACK TO FOR LIST, THEN DEFINE FIXUP F+1.
	;UNDISPLAY LABEL LIST, REMOVE FOR STATEMENT ENTRY FROM STACKS.

	LF()	ZHEDLV(XZHE)	;DISPL. OF FOR RETURN ADDRESS LOCATION
	OP	(JRST	@(XCB))
	GENABS
	LF(X2)	ZHEFIX(XZHE)	;DEFINE F+1
	LI	X1,1(X2)
	DEFIX
	L	X1,X2		;CLEAR F, F+1 FOR REUSE
	CLFIX
	LI	X1,1(X2)
	CLFIX
	UNDISPLAY
	EXEC	CAUS
	EXEC	CAUSTD
	SETZM	@YDCSTP
	NEXT
	SUBTTL	ENDPR,EPROG,ERROR

ENDPR.:	;--- END PROCEDURE ---
	;COMPILE RETURN FOR PURE PROCEDURE, CALL ON CSEP FOR TYPE PROCEDURE.
	;DEFINE FIXUP F+3 TENTATIVELY, RELEASE F+1, F+2.
	;OUTPUT PROCEDURE PROTOTYPE WITH MAPS OF ENCLOSED,
	;REDUCED SUBBLOCKS.

	ASSERT<	WHENNOT	XZHE,ZHB
		RFAIL	NOT ZHB AT ENDPROC
	>
	LF(X1)	ZHBZQU(XZHE)
	SETOFF	ZQUIB(X1)
	IF
		LF()	ZQUTYP(X1)
		CAIE	QNOTYPE	;NOTYPE PROCEDURE?
	THEN
	IFE	QSADEA,<
		L	X2,[-3,,[MOVE XSAC,OFFSET(ZDRARE)(XCB) ;RET ADDR AND B.I. ADDR
				HLRZ XCB,XSAC ;RESTORE XCB
				JRST (XSAC)]] ;EXIT
		LOOP
			L	(X2)
			GENABS
		AS
			INCR	X2,TRUE
		SA
	>
		GJRST(CSES)	;SAME AS SWITCH THUNK EXIT
	ELSE	;-- TYPE PROCEDURE --
		GJRST	CSEP
	FI
	LF(X2)	ZHEFIX(XZHE)
	EXEC	CAEB
	LI	X1,3(X2)
	HRROS	YTENT
	DEFIX
	LI	X1,1(X2)
	CLFIX
	LI	X1,2(X2)
	CLFIX
	NEXT

EPROG.:
	L	XZHE,YDCSTB
	IF	IFON	YSWCE
	THEN	; OUTPUT OUTERMOST PROTOTYPE
		EXEC	O2LN2	; LAST LINE NUMBER ENTRY
		L	X2,YDCSTB
		LF	X2,ZHEFIX(X2)
		LI	X1,2(X2)
		DEFIX
		LI	X1,3(X2)
		DEFIX
		LI	X1,4(X2)
		DEFIX
		EXEC	CAEB
		GPUSHJ(OCEP)
	FI
	BRANCH	O2EX	;--- END OF PROGRAM ---


ERROR.:	;--- SET FLAG TO GENERATE RTS ERROR INSTEAD OF CODE FOR CURRENT TREE ---

	SETON	SCERFL
	L	[RTSERR	QDSCON,QSORCERROR]	;[41]
	GENABS
	NEXT
	SUBTTL	FIX,FORDO,IENDC,INNER,JUMP

FIX.:	;--- DEFINE FIXUP VALUE ---

	INVAL
	L	X1,X0
	DEFIX
	NEXT


FORDO.:	;--- DO OF FOR STATEMENT ---
	;COMPILE JUMP TO FIXUP F+1
	;DEFINE AND RELEASE (F+2)
	;IF ANY SIMPLE FOR LIST ELEMENT WAS PRESENT,
	;COMPILE INSTR TO SAVE RET ADDR:
	;  MOVEM XSAC,RETURN ADDR(XCB)
	;DISPLAY LABEL LIST, DEFINE FIXUP F,
	;REMOVE NODE FOR CONTROLLED VAR FROM OPERAND STACK

	LF(X2)	ZHEFIX(XZHE)
	LI	1(X2)
	OP	(JRST)
	GENFIX
	LI	X1,2(X2)
	DEFIX
	CLFIX
	IF
		SKIPN	YFORSI
	THEN
		LF	,ZHEDLV(XZHE)
		OP	(MOVEM	XSAC,(XCB))
		GENABS
	FI
	DISPLAY
	LI	X1,(X2)
	DEFIX
	L	[QOPSTZ,,YOPST-1]
	ST	YOPSTP
;[30]	EXEC	CAUSTD		;MOVED TO CVBE. (OR)
	NEXT



IENDC.:	;--- END OF CLASS WITH NO EXPLICIT "INNER"
	;SET ZHENOI, THEN DO ACTIONS FOR INNER AND ENDCL.

	SETON	ZHENOI(XZHE)
	EXEC	INNER.
	BRANCH	ENDCL.	;RETURN FROM CA MODULE VIA ENDCL.


INNER.:	;--- "INNER" STATEMENT ---
	;OUTPUT CALL ON CPCI, DEFINE ZHEFIX+4

	EXEC	CAPL		;COMPILE /MOVEI XSAC,prefix level/
	GJRST(CPCI)
	LF(X1)	ZHEFIX(XZHE)
	ADDI	X1,4
	DEFIX
	NEXT

JUMP.:	;--- COMPILE JRST TO FIXUP FOLLOWING ---

	INVAL
	OP	(JRST)
	GENFIX
	NEXT
	SUBTTL	NOTHR,OPT,OTHER

NOTHR.:	;--- END OF INSPECTION WITHOUT OTHERWISE CLAUSE ---

	EXEC	OTHER.
	LI	X1,3(X2)
	DEFIX		;DEFINE FIXUP F+3 (END OF INSPECTION)
	NEXT


OPT.:	;OPTION CODE FOLLOWS
	INVAL
	HRRE
	IF	SKIPGE
	THEN	; ON SWITCH
		IORM	YSWITCH
	ELSE	; OFF SWITCH
		ANDM	YSWITCH
	FI
	NEXT


OTHER.:	;--- START OF OTHERWISE CLAUSE ---
	L	XZHE,YDCSTP	; INSPECT ZHB HAS JUST BEEN CAUSED
	LF()	ZHEDLV(XZHE)	;CODE TO CLEAR DISPLAY ENTRY
	OP	(SETZM	(XCB))
	GENABS
	LF(X2)	ZHEFIX(XZHE)
	L	X1,X2
	SETZM	@YDCSTP
	DEFIX
	EXEC	CAUSTD
	NEXT
	SUBTTL	PBEND,PURGE,SEMIC

PBEND.:	;--- END OF PREFIXED BLOCK ---
	;IF ANY PREFIX HAS AN EXPLICIT INNER, COMPILE A JUMP TO THE
	;INNERMOST SUCH PREFIX, OTERWISE SET XCB TO SURROUNDING
	;BLOCK ADDRESS.
	;DEFINE FIXUP F+4 (ZCPIEA).
	;UNDISPLAY, OUTPUT PROTOTYPE AND MAP(S), UNSTACK

	EXEC	CPEND
	IF
		SKIPE	X2
	THEN
		LF()	ZHBSBL(XZHE)
		MOVN
		OP	(MOVE	XCB,(XCB))
		GENABS
	FI
	LF(X2)	ZHEFIX(XZHE)
	LI	X1,4(X2)
	DEFIX
	LI	X1,5(X2)
	DEFIX
	EXEC	CAEB
	NEXT

PURGE.:	;--- FLAG A COMPILATION ERROR, PURGE OPERAND STACK 
	;AND PARTIAL CODE TREES

	L	[RTSERR	QDSCON,QSORCERROR]	;[41]
	GENABS
	BRANCH	CGPU


SWEND.:	;--- END OF SWITCH DECLARATION
STACK	YGAP
	STACK	YQREL
	LI	QRELPT
	ST	YGAP
	ST	YQREL
	HLRZ	X1,YCGSWC
	DEFIX
	HLRZ	X1,YCGSWC
	AOJ	X1,
	HRROS	YTENT
	UNSTK	YQREL	; THIS FIXUP IN CODE
	DEFIX
	HRRZ	YCGSWC
	GENABS
	MOVSI	2
	GENABS	; 2,,0
	L	X2,YZHET
	LF	X1,ZHEDLV(X2)
	HRLZ	X1
	GENABS	; -DLV,,0

	L	X2,YZHBXC
	LF	,ZHBSZD(X2)
	ADDI	3
	GENABS	; 0,,ZPCSZD
	SETZM	YCGSWC
	UNSTK	YGAP
	L	YORZHB
	ST	YZHBXC
	EXEC	CAUS
	NEXT
	LIT
	RELOC	0
	VAR
	END