perm filename CGPA.MAC[SIM,SYS] blob sn#459995 filedate 1979-07-20 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00022 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002		SUBTTL	PARAMETER HANDLING ON CALLING SIDE
C00006 00003		SUBTTL	=== BEGPB ===
C00008 00004		SUBTTL	=== NEW ===
C00011 00005		SUBTTL	CGACSA - code to save intermediate results
C00012 00006		SUBTTL	=== PCALL ===
C00016 00007		SUBTTL	[7] === CGQI === [7]
C00020 00008		SUBTTL	=== CGQIPA ===  [7]
C00022 00009		SUBTTL	=== CGPARM ===
C00026 00010		SUBTTL	CGPA.R,CGUSTD,CGNQ
C00028 00011		SUBTTL	=== CGPA.1 ===
C00032 00012		SUBTTL	=== CGPN ===
C00034 00013		SUBTTL	=== CGPV ===
C00036 00014		SUBTTL	=== CGNN ===
C00038 00015		SUBTTL	=== CGNS ===
C00040 00016		SUBTTL	=== CGNC ===
C00041 00017		SUBTTL	=== CGPAGC ===
C00042 00018		SUBTTL	=== CGNX ===
C00044 00019		SUBTTL	=== CGPADT ===
C00046 00020		SUBTTL	=== CGTHUNK ===
C00049 00021		SUBTTL	=== CGFL ===
C00052 00022		SUBTTL	=== CGZAP ===
C00056 ENDMK
CāŠ—;
	SUBTTL	PARAMETER HANDLING ON CALLING SIDE
		SALL
		COMMENT;
AUTHOR:		LARS ENDERIN 2-AUG-73

VERSION:	1C(10)

PURPOSE:	CODE  GENERATION

CONTENTS:	GENERATORS FOR  NODES IN EXPRESSION TREE:

		ZNS NODES %BEGPB, %NEW, %PCALL
;
	SEARCH	SIMMAC,SIMMC2,SIMMCR,SIMRPA
	CTITLE	CGPA

	EXTERN	CAUS,CGAD,CGCA,CGCC,CGCO,CGVA,CGLO,CGLO1,CAUSTD
	EXTERN	YOPST
	EXTERN	CGRA,CGPD

	EXTERN	CADS,CAUD
	EXTERN	CGAS,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4,CGSY
	EXTERN	O2AD,O2AF,O2GI
	EXTERN	CGIM,CGIM1,CGMO,CGMO1
	EXTERN	O2CF,O2DF,O2GA,O2GF,O2GR,O2GW,O2GWD,O2IV
	EXTERN	YCGFX1,YACTAB,YCGFX2,YFORSI,YLXIAC,YO2ADI,YO2ADF,YOPCOD
	EXTERN	YOPSTB,YOPSTP,YORFOR,YQRELR,YQRELT,YRELPT,YZHET,YRELCD
	EXTERN	YCGINS,YORACT,YORFX,YTAC,YZHBXC
	EXTERN	YGETAC,YRELAC ;[7]

	EXTERN	CABSTU,CGAC,CGRD,CGRN,CGCCCH
	EXTERN	YACTAB,YCGACT
	EXTERN	YCGPAF	;SWITCHES ONLY IN LEFT HALF
	EXTERN	YCGDBL,YPAFIX

; COMPILE OPDEFS
; ==============
	OPDEF	ALFIX	[PUSHJ	XPDP,O2AF] ;Allocate any free fixup no
	OPDEF	IFLR	[CAIE	X6,QLREAL] ;Skip if X6 = type code for long real
	OPDEF	LR	[CAIN	X6,QLREAL] ;Converse of IFLR
	OPDEF	OPAC	[OP	(XL1)]	   ;Modify val of index field by XL1
	OPDEF	OPZAC	[OPZ	(XL1)]	   ;Modify val of index field by XL1
	OPDEF	GENRLD	[PUSHJ	XPDP,CGRD]

; MACROS
DEFINE	FIRSTOP=<LF	XP1,ZNSZNO(XCUR)>
	MACINIT
	CGINIT
	TWOSEG
	RELOC	400K

INTERN	.BEGPB,.NEW,.PCALL,CGACSA

;SWITCHES
;--------
 DSW	STHUNK,YCGPAF,1,0	;ON IF ANY THUNK FOR CURRENT PARAMETER LIST
 DSW	SNOFML,YCGPAF,0,0	;ON IF FORMALS NOT KNOWN
 DSW	SQUICK,YCGPAF,2,0	;[7] On for QUICK procedure

;Local field definitions
 DF CALLID,YCGPAF,12,17	;[7] Id no of called QUICK procedure

 OPDEF	RH	[POINT	18,0,35]
 RH==RH
 DEFINE RIGHTHALF(A)<
 IFN <RH-<<$'A>&<777777B17>>>,
  <CFAIL	A IS NOT IN RH>>

;Local register designations
XK=X4	;(FORMAL) KIND
XM=X5	;(FORMAL) MODE
XT=X6	;(FORMAL) TYPE
	SUBTTL	=== BEGPB ===

COMMENT;
INPUT ASSERTION:	THE DECLARATIONS HAVE BEEN PROCESSED, AND THE
			BLOCK STACK INDICATES THE PREF BLK AS THE CURRENT ONE.
			XZHE POINTS TO THE ZHE OF THE PBLOCK.

GENERATED CODE:		MOVEI	XSAC,prefixed block prototype
			PUSHJ	XPDP,CPSP
			<Transmit any parameters>
;

.BEGPB:	LF	,ZHEFIX(XZHE)	;Prototype fixup no
	OP	(MOVEI	XSAC,)
	GENFIX
	GPUSHJ	CPSP
	LF	XP1,ZNSZNO(,YOPST) ;Get ZID node of class
	IFOFF	ZNOLST(XP1)	;Has parameters if this is not the last node
	EXEC	CGPARM
	L	X1,YZHET
	LF	X1,ZHEFIX(X1)	;Define FIX+2 (start of decl coding)
	LI	X1,2(X1)
	DEFIX
	EXEC	CAUSTD		;Update display index
	RETURN
	SUBTTL	=== NEW ===

COMMENT;
INPUT ASSERTION:	XCUR POINTS TO A %NEW NODE (ZNS).
			THE FIRST OPERAND IS THE ZID OF THE CLASS.
GENERATED CODE:		:IF ANY RESULTS MUST BE SAVED:
			[PUSHJ	XPDP,CSSA
			XWD	no. of intermediate results,address of acs map]
			PUSHJ	XPDP,CPNE
			XWD	display offset,class prototype
			<transfer any parameters and enter>
;

.NEW:	FIRSTOP
	;[47]
	LF	X2,ZIDZQU(XP1)
	LF	X1,ZQUZB(X2)
	;CHECK IF SIMULATION OR SIMSET IN PREFIX CHAIN
	LOOP
		IF	;System class
			IFOFF	ZQUSYS(X2)
			GOTO	FALSE
		THEN
			IF	;Simulation or Simset
				LF	X0,ZQULID(X2)	;IDENTIFIER NUMBER
				CAIN	X0,QIDSIM
				GOTO	TRUE		;ERROR
				CAIE	X0,QIDSET
				GOTO	FALSE		;OK
			THEN	;Generate error message at compile- and run-time
				LF	X2,ZIDZQU(XP1)
				LF	X1,ZQULID(X2)
				ERRI1	QE,423	;NEW XXXX IS AN ILLEGAL OBJECT GENERATOR
				L	[RTSERR QDSCON,QSORCER]
				GENABS
				GOTO	.NEW01
			FI
		FI
	AS
		;CHECK IF PREFIX EXIST
		LF	X1,ZHBZHB(X1)	
		JUMPE	X1,FALSE		;NO MORE PREFIX
		LF	X2,ZHBZQU(X1)
		GOTO	TRUE
	SA
	
	;[47] END
	GETAC2
	EXEC	CGACSA	;CODE TO SAVE ACS, IF ANY
	GPUSHJ	(CPNE)
	LF	X2,ZIDZQU(XP1)	;ZQU of class
	IF	;[111] Class decl AND its declaring block are both
		;      visible by connection
		IFOFF	ZQUIS(X2)
		GOTO	FALSE
		LF	X3,ZQUZHE(X2)
		LF	X1,ZHBZQU(X3)
		IFOFF	ZQUIS(X1)
		GOTO	FALSE
	THEN	;Use DLV of declaring block
		LFE	X1,ZHEDLV(X3)
	ELSE	;Use SBL of the class itself
		LF	X1,ZQUZB(X2)
		LF	X1,ZHBSBL(X1)
		MOVN	X1,X1
	FI	;[111]
	LF	,ZQUIND(X2)	;PROTOTYPE FIXUP
	HRL	X1		;DISPLAY OFFSET
	GENFIX			;XWD	display offset,prototype of class
	IFOFF	ZNOLST(XP1)
	EXEC	CGPARM		;Handle parameters
	RELAC2
.NEW01:	;[47]
	RETURN
	SUBTTL	CGACSA - code to save intermediate results

COMMENT;
PURPOSE:	TO GENERATE CODE TO SAVE INTERMEDIATE RESULTS, IF ANY
GENERATED CODE:	(ONLY IF NECESSARY)
		PUSHJ	XPDP,CSSA
		XWD	number of intermediate results, address of map
;
CGACSA:	PROC
	SAVE	X1
	HRRZ	YTAC
	IF	;More than one ac on stack
		CAIN	YACTAB
		GOTO	FALSE
	THEN	;Emit code to save ac's in ZAC object
		GPUSHJ	CSSA
		EXEC	CGAC
	FI
	SETZM	YLXIAC	;Must assume XIAC destroyed after call
	RETURN
	EPROC
	SUBTTL	=== PCALL ===

COMMENT;
INPUT ASSERTION:	NODE %PCALL WITH OPERANDS:
			ZID/ZNS NODE,FOLLOWED BY ANY PARM NODES WITH ACTUAL AND
			FORMAL PARAMETER NODES AS SUBNODES.

GENERATED CODE:		(1) SIMPLE CASE - STATICALLY VISIBLE PROCEDURE:
			:IF ANY RESULTS MUST BE SAVED:
			[PUSHJ	XPDP,CSSA
			XWD	no. of intermediate results,address of acs map]
			MOVEI	XSAC,procedure prototype
			PUSHJ	XPDP,CSSN
			[parameter transmission and procedure entry]

			(2) MORE COMPLICATED CASES - PROC IN INSPECTED
			CLASS, REMOTE, FORMAL, VIRTUAL OR NOCHECK PROCEDURE:
			compute ZDP of procedure to XWAC1 & XWAC2
			PUSHJ	XPDP,CSSW   or   PUSHJ XPDP,CSSW0
			XWD	no. of intermediate results,address of acs map
			[parameter transmission and procedure entry]
;

.PCALL:	PROC
	FIRSTOP
	IF
		RECTYPE(XP1) IS ZID
		GOTO	FALSE
		LF	X1,ZIDZQU(XP1)
		LF	X2,ZIDMOD(XP1)
		IFOFF	ZQUIS(X1)	;NOT MADE VISIBLE BY CONNECTION
		CAIE	X2,QDECLARED	;AND DECLARED
		GOTO	FALSE
		LF	X2,ZQUZB(X1)
		JUMPE	X2,FALSE
	THEN	;Normal case (unless NOCHECK)
		JSP	X3,CGQIQS	;[7] Check for QUICK or sys calling sequence
		IFON	ZHBNCK(X2)	;[7]
		GOTO	L2		;[7]
		EXEC	CGACSA		;Save any intermediate results
		LF	X1,ZIDZQU(XP1)	;------------------------;
		LF	,ZQUIND(X1)	; MOVEI XSAC,proc. prot. ;
		OP	(MOVEI	XSAC,)	; PUSHJ XPDP,CSSN	 ;
		GENFIX			;------------------------;
		GPUSHJ	CSSN
	ELSE
		JSP	X3,CGQISY	;[7] Check for sys calling sequence
				;-------------------------------------------;
L2():!		COMPVAL	;[7]  	; Dyn addr of procedure to XWAC1+n, XWAC2+n ;

		;[24] Generate PUSHJ  XPDP,CSSW0  for formal or virtual
		;  procedure calls without parameter list

		IF
			IFEQF	(XP1,ZIDMOD,QDECLARED)
			GOTO	FALSE
			IFOFF	ZNOLST(XP1)
			GOTO	FALSE
		THEN
					;-------------------------------;
			GPUSHJ	CSSW0	; PUSHJ XPDP,CSSW0		;
					;-------------------------------;
		ELSE
					;-----------------------------------;
			GPUSHJ	CSSW	; PUSHJ	XPDP,CSSW		    ;
					;-----------------------------------;
		FI

				;-------------------------------------------;
		EXEC	CGAC	; XWD	n,admap				    ;
				;-------------------------------------------;
	FI
	IFOFF	ZNOLST(XP1)
	EXEC	CGPARM		;Handle parameters
	RELAC2
	EXEC	CGCCCH		;Possible SKIP instr if part of conditional
	RETURN
	EPROC


CGQIQS:	LF	,ZHBMFO(X2)	;[7]
	CAIN	QEXMQI		;[7] QUICK procedure?
	BRANCH	CGQI		;[7] Treat specially
CGQISY:	IFON	ZQUSYS(XP1)	;[7]
	BRANCH	CGSY		;[7] System procedure
	GETAC2			;[7]
	BRANCH	(X3)		;[7] RETURN
	SUBTTL	[7] === CGQI === [7]

Comment/
Input assertion:
	XP1 points to a ZID node for an external MACRO-10
	procedure which should have a special quick calling
	sequence similar to the calling sequences of Outtext,
	Histo, Inint etc., i e parameters are passed in
	successive registers, normally starting with XWAC1.
	X1 :- ZIDZQU(XP1), X2:-ZQUZB(X1).
Generated code:
(1)	Compute parameters to successive ac's starting with Xtop.
(2a)	;(with CHECK option):
	MOVEI	XTAC,Xtop	;Only for <type> procedure
(2b)	;(NOCHECK):
	SKIPA	XTAC,.+1
	XWD	-n, Xtop	;n = number of actual parameters
;or if n = 0:
	MOVEI	XTAC,Xtop
(3)	PUSHJ	XPDP,entry
/

CGQI:	PROC
	IF	;Parameters are checked
		IFON	ZHBNCK(X2)
		GOTO	FALSE
	THEN
		LF	X3,ZHELEN(X2)	;Number of ac's needed = block length
		IF	;Any ac's needed
			JUMPLE	X3,FALSE
		THEN	;Compute parameters to successive ac's
			EXEC	CGQIPA
		FI
		LF	X1,ZIDZQU(XP1)
		LF	,ZQUTYP(X1)
		IF	;Type procedure (function)
			CAIN	QNOTYPE
			GOTO	FALSE
		THEN	;Tell the function which is the top ac
			HRRZ	@YTAC
			OP	(MOVEI	XTAC,)
			GENABS
		FI
	ELSE	;NOCHECK procedure
		IF	;No parameters given
			IFOFF	ZNOLST(XP1)
			GOTO	FALSE
		THEN	;Simple calling seq
			STACK	[0]	;Number of parameters
		ELSE	;Compute parameters
			STEP	XP1,ZNS,X1
			EXEC	CGPANO
			STACK	X0	;Number of parameters
			L	X3,X0
			ADD	X3,X0	;Twice as many ac's needed
			IF	;[34] Too many
				CAIG	X3,QNAC
				GOTO	FALSE
			THEN	;Error
				L	X1,X3
				ERRI1	QE,<Q2.ERR+66>
				L	[RTSERR QDSCON,QSORCER]	;[41]
				GENABS
			ELSE	;Handle parameters
				LF	X1,ZIDZQU(XP1)	;[34] Restore X1
				EXEC	CGQIPA
			FI	;[34]
		FI
		UNSTK	X1	;Number of parameters
		IF	;There were any
			JUMPE	X1,FALSE
		THEN	;We need two instructions
			LI	1
			ADD	YRELCD
			OP	(SKIPA	XTAC,)
			GENRLD			;[SKIPA XTAC,.+1]
			MOVN	X1
			HRLZ
		ELSE	;Just one instruction
			OP	(MOVEI	XTAC,)
		FI
		HRR	@YTAC		;Xtop
		GENABS			;[XWD -n,Xtop] or [MOVEI XTAC,Xtop]
	FI
	LF	X1,ZIDZQU(XP1)	;Generate PUSHJ to procedure entry
	LF	,ZQUIND(X1)	;Fixup for entry point
	OP	(PUSHJ XPDP,)
	GENFIX
	SETZM	YLXIAC		;XIAC will probably be destroyed
	EXEC	CGCCCH		;Possible skip instr if part of conditional
	RETURN
	EPROC
	SUBTTL	=== CGQIPA ===  [7]

Comment;

Purpose:		To compute parameters to successive ac's for a call on
			a "QUICK" external procedure.
Input assertion:	XP1 points to ZID of procedure, followed by a
			parameter list, consisting of %PARM nodes,
			each with an actual/formal parameter node pair as
			subnodes. X3 has number of ac's needed for parameters.
			X1 :- ZIDZQU of procedure. X2:-ZQUZB(X1).
Code generated:		Actual parameter computation to ac's.
;

CGQIPA:	PROC
	SAVE	<XP2,XV1,XV2,XL1,XL2>	;[34]
	SETZM	YLXIAC	;Make sure XIAC is reloaded when needed
	STACK	YCGDBL
	STACK	YCGPAF
	HRRZS	YCGPAF		;Reset switches
	SETON	SQUICK
	IFON	ZHBNCK(X2)	;[34]
	SETON	SNOFML
	LF	,ZQULID(X1)	;Get lexical id of proc to use in case of error
	SF	,CALLID
	XCT	YGETAC-1(X3)	;Reserve ac's for all parameters
	STACK	YTAC		;Save YACTAB status
	STEP	XP1,ZNS,XP2	;XP2:-first %PARM node
	LI	XL2,QLOWID	;[34] Signifies parameter number: 1
	LOOP
		EXEC	CGPA.1
	AS	IFON	ZNOLST(XP2)
		GOTO	FALSE
		STEP	XP2,ZNS
		AOJA	XL2,TRUE	;[34] Count parameters
	SA
	UNSTK	YTAC
	XCT	YRELAC		;Let go of ac's
	UNSTK	YCGPAF
	UNSTK	YCGDBL
	RETURN
	EPROC
	SUBTTL	=== CGPARM ===

COMMENT;

PURPOSE:		TRANSMITS PARAMETERS TO CLASSES, PREFIXED BLOCKS
			AND PROCEDURES.

INPUT ASSERTION:	XP1 POINTS TO ZID OF PROCEDURE OR CLASS, FOLLOWED
			BY A PARAMETER LIST, CONSISTING OF %PARM NODES,
			EACH WITH ACTUAL/FORMAL SUBNODES, OR, FOR PARAMETERS
			TO FORMAL OR VIRTUAL PROCEDURES, AN ACTUAL PARAM. LIST.
			THE ADDRESS OF THE OBJECT HAS BEEN COMPUTED TO XWAC1
			BY CSSN, CSSW, CPNE OR CPSP.

CODE GENERATED:		<parameter transmission>
			PUSHJ	XPDP,CSEN
;

CGPARM:	PROC
	SAVE	<XP2,XV1,XV2,XL1>
	EXEC	CGPD		;Save ac stack description, start over
	SETZM	YLXIAC		;Make sure XIAC is reloaded when needed
	STACK	YCGPAF		;Save recursion data
	STACK	YCGDBL
	STACK	YPAFIX
	L	X1,YZHBXCB
	LF	,ZHBSTD(X1)	;SAVE CURRENT STD
	MOVN	X2,		;IN MORE USEFUL FORM (NEGATED)
	HRRZM	X2,YCGPAF	;SWITCHES IN LEFT HALF ARE RESET
;[7]	EXEC	CGUSTD
	STEP	XP1,ZNS,XP2
	IF	;ZNS(%PARM)
		WHENNOT(XP2,ZNS)
		GOTO	FALSE
		IFNEQF(XP2,ZNSGEN,%PARM)
		GOTO	FALSE
	THEN
		LI	[BYTE	(6)QZNS(2)0(4)QREF(3)QDECLARED(3)QSIMPLE
			0]
		; THE LITERAL ABOVE IS A DUMMY ZNS NODE USED TO
		; DESCRIBE THE RETURNED PROCEDURE INSTANCE IN XWAC1
		HRLM	@YTAC	;Update YTAC
		AOS	YTAC
		SETOFF	SNOFML
	ELSE	;Only actual parameters known
		L	X1,XP2
		EXEC	CGPANO	;Count parameters in X0
		GENABS		;NUMBER OF PARAMETERS (Z  n)
		GPUSHJ	(PHPT)
		SETON	SNOFML	;No formals known
	FI
	ALFIX		;ALLOCATE FIXUP FOR SKIPPING THUNKS
	HRL	YCGPAF
	ST	YPAFIX	;offset of object save loc,,fixup no.
	LOOP	;For each actual parameter
		EXEC	CGPA.1
	AS
		IFON	ZNOLST(XP2)
		GOTO	FALSE
		STEP	XP2,ZNS
		GOTO	TRUE
	SA

	GPUSHJ	CSEN
	L	X1,YZHBXCB
	MOVN	YCGPAF
	SF	,ZHBSTD(X1)
	HRRZ	X1,YPAFIX
	CLFIX
	UNSTK	YPAFIX
	UNSTK	YCGDBL
	UNSTK	YCGPAF
	EXEC	CGRA	;Restore old ac stack description (YACTAB)
	RETURN
	EPROC


CGPANO:	;Count parameters starting at (X1)
	LI	1	;Count in X0
	LOOP
		HLL	X1,OFFSET(ZNOLST)(X1)
		ADDI	X1,ZNO%S
	AS	;long as we have more parameters
		IFOFFA	ZNOLST(X1)
		AOJA	TRUE
	SA
	RETURN
	SUBTTL	CGPA.R,CGUSTD,CGNQ

REPEAT 0,<
CGPA.R:	PROC	;RECOVER POINTER TO CLASS/PROC/PBLK INSTANCE
		;X2 HOLDS NUMBER OF AC TO GET THE OBJECT ADDRESS
	HRRZ	YCGPAF
	OP	(HLRZ	(XCB))
	DPB	X2,[ACFIELD]
	GENABS
	LI	X2,XWAC1
	RETURN
	EPROC
>

CGUSTD:	PROC	;INCREASE STD BY 1, POSSIBLY UPDATE SZD (MAX STD VALUE)
		;X1 POINTS TO ZHB. X2 IS DESTROYED.
	SIZE	(QMS,ZHBSTD)
	LF	,ZHBSTD(X1)
	LF	X2,ZHBSZD(X1)
	ADDI	1
	 CAIL	<1ā†<QMS>>
	ERROR2	50,DISPLAY SIZE OVERFLOW
	CAMLE	X2
	SF	,ZHBSZD(X1)
	SF	,ZHBSTD(X1)
	RETURN
	EPROC

CGNQ:	;Set ZFLZQU for id or expression of type REF
	LF	,ZNSTYP(XP1)
	CAIE	QREF
	RETURN
	LF	X1,ZNSZQU(XP1)
	WHEN	(XP1,ZNN)	;[1]	If thunk was compiled
	LF	X1,ZNNZQU(XP1)	; use ZNNZQU instead of ZNSZQU
	LF	,ZQUIND(X1)	;Fixup for qualif. prototype
	OPAC	(HRLI	1,)
	GENFIX			;! HRLI Xtop+1,qualif. prototype !;
	RETURN
	SUBTTL	=== CGPA.1 ===

COMMENT;
PURPOSE:		COMPILE CODE TO HANDLE TRANSMISSION OF ONE
			PARAMETER TO A CLASS,PROCEDURE OR PREFIXED BLOCK.
INPUT ASSERTION:	XP2 POINTS TO THE CURRENT %PARM NODE, OR IF ONLY
			ACTUAL PARAMETERS ARE KNOWN,XP2 POINTS TO 
			THE FIRST ACTUAL PARAMETER.

;

CGPA.1:	PROC
	SAVE	XP2
	STACK	XP1
	HRRZ	XL1,@YTAC	;[7] Prepare for OPAC, OPZAC
	LSH	XL1,5		;[7]
	HRLM	XL1,YCGACT	;[7]
	SETZM	YCGDBL
	IF	;FORMAL PARAMETER NOT KNOWN AT COMPILE TIME
		IFOFF	SNOFML
		GOTO	FALSE
	THEN
		L	XP1,XP2
		IF	;[7] not QUICK
			IFON	SQUICK
			GOTO	FALSE
		THEN	EXEC	CGZAP
			UNSTK	XP1	;[7]
		ELSE	;[7] QUICK, fake formal node
			EXEC	CGPA.F	;Kind (XK), mode (XM), type (XT)
			GOTO	L1
		FI	;[7]
	ELSE
		LF	XP1,ZNSZNO(XP2)	;XP1:-ACTUAL PARM NODE
		STEP	XP1,ZNS,XP2	;XP2:-FORMAL NODE
		EXEC	CGPA.F		;FORMAL(KIND, MODE, TYPE) TO (XK, XM, XT)
		IF	;VALUE mode
			CAIE	XM,QVALUE
			GOTO	FALSE
		THEN
			EXEC	CGPV
		ELSE
		IF	;REFERENCE mode
			CAIE	XM,QREFERENCE
			GOTO	FALSE
		THEN
			IF	;NOT AN ARRAY
				CAIN	XK,QARRAY
				GOTO	FALSE
			THEN
				IF	;KIND PROCEDURE
					CAIE	XK,QPROCEDURE
					GOTO	FALSE
				THEN	;TWO WORDS DYNAMIC ADDRESS EXCEPT FOR SWITCH
					CAIE	XT,QLABEL
					AOS	YCGDBL
				ELSE	;TWO WORDS FOR SIMPLE TEXT OR LABEL
					CAIE	XT,QTEXT
					CAIN	XT,QLABEL
					AOS	YCGDBL
				FI
			FI
			COMPVAL
		ELSE	;--- MUST BE BY NAME, THEN ---
			ASSERT <CAIE	XM,QNAME
				RFAIL	NONEXISTENT MODE>
	L1():!		IFON	SQUICK	;[73] Must have correct YACTAB reference
		HRLM	XP1,@YTAC;(No COMPxxx proc will be called to do this)
		EXEC	CGPN
		FI	FI
		UNSTK	XP1	;[7]
		IF	;[7] Normal case
			IFON	SQUICK
			GOTO	FALSE
		THEN	;[7]
			;--- MOVE PARAMETER TO FORMAL POSITION.
			;--- USE NEXT FREE AC FOR THE OBJECT ADDRESS
			L	X3,@YTAC
			LI	X2,XWAC1
			LF	X1,ZIDZQU(XP2)
			LF	,ZQUIND(X1)
			OP	(MOVEM)
			SKIPE	YCGDBL
			KA10WARNING
			OP	(DMOVEM)
			DPB	X2,[INDEXFIELD]
			DPB	X3,[ACFIELD]
			GENABS
		ELSE	;[7] Leave parameter in ac(s)
			IF	;[73] Name mode transmission
				LF	XM,ZIDMOD(XP2)
				CAIN	XM,QNAME
				GOTO	TRUE
				IFOFF	SNOFML
				GOTO	FALSE
			THEN	;Change node to ZNN node for "computed addr"
				;This is to arrange for correct ac map when
				;necessary for following parameter evaluations
				HLRZ	X1,@YTAC
				LI	ZNN%V
				SF	,ZNOTYP(X1)
				LI	QCODCA
				SF	,ZNNCOD(X1)
			FI	;[73]
			AOS	YTAC
			SKIPE	YCGDBL
			AOS	YTAC
		FI	;[7]
	FI
	RETURN
	EPROC
	SUBTTL	=== CGPN ===

COMMENT;
PURPOSE:		COMPILE ZFL TO Xtop & Xtop+1.
			A THUNK IS COMPILED IF NECESSARY.
INPUT ASSERTION:	THE FORMAL PARAMETER IS KNOWN AND SPECIFIED NAME.
			XP1 POINTS TO THE ACTUAL PARAMETER NODE.
;

CGPN:	PROC
	ASSERT	<RIGHTHALF ZFLZBI>
	AOS	YCGDBL		;ALWAYS TWO WORDS FOR NAME PARAMETER
	L	X3,@YTAC
	LF	,ZNOTYP(XP1)	;[64] Node type
	CAIN	QZNS	;[31]
	BRANCH	CGNX	;[31] ZNS node implies expression
;--- CHECK FOR CONSTANT PARAMETER ---
	CAIN	QZCN
	BRANCH	CGNC
;--- CHECK FOR NAME PARAMETER AS ACTUAL PARAMETER ---
	LF	X1,ZIDMOD(XP1)
	CAIN	X1,QNAME
	BRANCH	CGNN
	ASSERT	<
	CAIE	QZID	;[64] If not ZID node here, something is fishy
	RFAIL	CGPN not ZID
	>
;--- CHECK IF ZID NODE NEEDS THUNK ---
	LF	,ZIDKND(XP1)
	LF	X1,ZIDTYP(XP1)
	;PROCEDURE, SWITCH OR LABEL
	CAIE	QPROCEDURE 
	CAIN	X1,QLABEL
	BRANCH	CGNX
;--- SIMPLE TYPE OF DESCRIPTOR HERE ---
	BRANCH	CGNS
	EPROC
	SUBTTL	=== CGPV ===

COMMENT;
PURPOSE:		COMPILE VALUE OF PARAMETER TO Xtop & Xtop+1.
INPUT ASSERTION:	XP1 POINTS TO AN ACTUAL PARAMETER NODE. THE
			CORRESPONDING FORMAL PARAMETER IS SPECIFIED VALUE.
			TYPE AND KIND OF FORMAL ARE IN XK,XT.
;

CGPV:	PROC
	IF	;Simple value type
		CAIG	XT,QBOOLEAN
		CAIE	XK,QSIMPLE
		GOTO	FALSE
	THEN	;Compute the value
		CAIN	XT,QLREAL
		AOS	YCGDBL
		COMPVAL
	ELSE
	IF	;ARRAY
		CAIE	XK,QARRAY
		GOTO	FALSE
	THEN	;Use CSCA with inline acs descriptor ;[7]
		COMPVAL
		GPUSHJ	(CSCA)	;COPY ARRAY OBJECT
		EXEC	CGAC	;[n,,admap]
	ELSE
	IF	CAIE	XT,QTEXT
		GOTO	FALSE
	THEN
		AOS	YCGDBL
		COMPVAL
		GPUSHJ	(TXCY)	;COPY THE TEXT OBJECT
		EXEC	CGAC	;[7] XWD n,admap
	ASSERT<
	ELSE
		RFAIL	<REF LABEL OR NOTYPE ILLEGAL BY VALUE>
	>
	FI	FI	FI
	RETURN
	EPROC
	SUBTTL	=== CGNN ===

COMMENT;
PURPOSE:		TO GENERATE CODE FOR PASSING A NAME PARAMETER
			TO A PROCEDURE, WHEN THE ACTUAL PARAMETER IS ALSO
			SPECIFIED BY NAME ON THE CALLING SIDE
INPUT ASSERTION:	X3=Xtop
;

CGNN:	PROC
	LF	X1,ZIDZQU(XP1)
	GETAD
	OPZ	(DMOVE)
	ST	YOPCOD
	GENOP
	LF	X2,ZIDTYP(XP1)
	IF	;ACTUAL TYPE =/= FORMAL TYPE
		CAIN	XT,(X2)
		GOTO	FALSE
	THEN	;MODIFY ZFLFTP, ZFLCNV
	;! MOVEI Xtop+2,formal type code !;
		L	XT
		OPAC	(MOVEI	2,)
		GENABS
	;! DPB	Xtop+2,[$ZFLCTP(Xtop)] !;	CNV BIT CLEARED WITH ZFLFTP
		L	[$ZFLCTP]
		DPB	X3,[INDEXFIELD]
		GENWRD
		OPAC	(DPB	2,)
		GENREL
	;! LDB	Xtop+3,[$ZFLATP(Xtop)] !;
		L	[$ZFLATP]
		DPB	X3,[INDEXFIELD]
		GENWRD
		OPAC	(LDB	3,)
		GENREL
	;! CAIE	Xtop+3,formal type code !;
		L	XT
		OPAC	(CAIE	3,)
		GENABS
	;! TLO	Xtop,(1B<%ZFLCNV>) !;
		LI	(1B<%ZFLCNV>)
		OPAC	(TLO)
		GENABS
	FI
	IF	;[7] QUICK procedure
		IFOFF	SQUICK
		GOTO	FALSE
	THEN	;Must guard against unequal types or thunk
		LI	(1B<%ZFLCNV>)
		OPAC	(TLNN)	;! TLNN Xtop,(1B<%ZFLCNV>)
		GENABS
		LI	(1B<%ZFLNTH>)
		OPAC	(TLNN)	;! TLNN	Xtop,(1B<%ZFLNTH>)
		GENABS
		L	[RTSERROR 102] ;Complicated parameter to QUICK proc
		GENABS
	FI	;[7]
	RETURN
	EPROC
	SUBTTL	=== CGNS ===
COMMENT;
PURPOSE:		COMPILE ZFL TO Xtop & Xtop+1 FOR SIMPLE VARIABLE,
			ARRAY OR TEXT.
INPUT ASSERTION:	XP1 POINTS TO A ZID NODE WHICH IS NOT FOR A PROCEDURE,
			LABEL OR SWITCH.
CODE GENERATED:		MOVSI	Xtop,ZFL flags
			HRR	Xtop,display displ. of declaring block(XCB)
			MOVEI	Xtop+1,offset of actual parameter in its block
			For a REF quantity:
			HRLI	Xtop+1,prototype address
;

CGNS:	PROC
	MOVSI	X2,(<QDTVSI>B<%ZFLDTP>)
	EXEC	CGFL1
	;CODE TO LOAD BLOCK INSTANCE OF PARAMETER FROM DISPLAY OF XCB
	LF	X2,ZIDZQU(XP1)
	LF	X1,ZQUZHE(X2)
	LF	,ZHEDLV(X1)
	OPAC	(HRR	(XCB))
	GENABS	;! HRR	Xtop,display level(XCB) !;
	LF	,ZQUIND(X2)
	OPAC	(MOVEI	1,)
	GENABS	;! MOVEI Xtop+1,offset of actual parameter !;
	BRANCH	CGNQ	;Compile ZFLZQU if REF
	EPROC
	SUBTTL	=== CGNC ===

COMMENT;
PURPOSE:		COMPILE FORMAL LOCATION FOR CONSTANT
INPUT ASSERTION:	XP1 POINTS TO ZCN NODE FOR THE ACTUAL PARAMETER
CODE GENERATED:		MOVSI	Xtop,ZFL flags
			MOVEI	Xtop+1, address of constant
;
CGNC:	PROC
	OPZAC	XV1,(MOVEI 1,)
	MOVSI	X2,(<QDTCON>B<%ZFLDTP>)
	EXEC	CGFL1
	LF	X1,ZIDTYP(XP1)
	EXEC	CGPAGC
	RETURN
	EPROC
	SUBTTL	=== CGPAGC ===

COMMENT;
PURPOSE:		GENERATE A LITERAL CONSTANT IF NECESSARY AND COMPILE
			A RELOCATABLE INSTRUCTION WITH THE ADDRESS OF THE
			CONSTANT IN THE RIGHT HALF, AND THE LEFT HALF AS 
			SUPPLIED BY XV1 LEFT HALF.
INPUT ASSERTION:	XP1 POINTS TO A ZCN NODE FOR AN ACTUAL PARAMETER.
;

CGPAGC:	PROC
	IF	CAIE	X1,QTEXT
		GOTO	FALSE
	THEN
		COMPAD	;NOTE THE SPECIAL USE MADE OF COMPAD FOR TEXT CONSTANT

	ELSE
		WLF	,ZCNVAL(XP1)
		IF
			CAIE	X1,QLREAL
			GOTO	FALSE
		THEN
			LD	@
			GENDW
		ELSE
			GENWRD
		FI
		HLL	XV1
		GENREL	;! opcode or left hw,address of constant !;
	FI
	RETURN
	EPROC
	SUBTTL	=== CGNX ===

COMMENT;
PURPOSE:		COMPILE THUNK AND FORMAL LOCATION FOR AN ACTUAL
			PARAMETER CORRESPONDING TO A FORMAL PARAMETER BY NAME,
			WHEN THE ACTUAL PARAMETER HAS A ZNS NODE OR IS
			A PROCEDURE, LABEL OR SWITCH.
;


CGNX:	PROC
	IF	;[7] QUICK procedure
		IFOFF	SQUICK
		GOTO	FALSE
	THEN	;Cannot handle it - error
		L	X1,XL2		;[34] Param identification
		LF	X2,CALLID	;Id no of procedure
		ERRI2	QE,<Q2.ERR+67>	;[34] Too complicated
		L	[RTSERROR QDSCON,QSORCER];Prevent execution	;[41]
		GENABS
		RETURN
	FI	;[7]
	;ALWAYS GENERATE A THUNK
	HRRZ	YPAFIX
	OPAC	(JSP	1,)
	GENFIX	;! JSP  Xtop+1,past thunk !;
	EXEC	CGPA.F
	EXEC	CGTHUNK
	EXEC	CGPAFX
	EXEC	CGPA.F
	L	X2,XV1
	EXEC	CGFL2
	HRRZ	@YTAC
	OP	(HRRM	XCB,)
	GENABS	;! HRRM XCB,Xtop !;
	BRANCH	CGNQ	;Compile ZFLZQU for REF
	EPROC


COMMENT;
PURPOSE:		LOAD KIND,MODE,TYPE OF XP2 NODE TO XK,XM,XT
;

CGPA.F:	PROC
	LF	XM,ZIDMOD(XP2)
	LF	XK,ZIDKND(XP2)
	LF	XT,ZIDTYP(XP2)
	RETURN
	EPROC
	SUBTTL	=== CGPADT ===

COMMENT;
PURPOSE:	DETERMINE IF AN ACTUAL PARAMETER EXPRESSION SHOULD YIELD
		A DYNAMIC ADDRESS OR AN EXPRESSION VALUE, GIVEN THAT A
		THUNK WILL BE COMPILED, I E THE SIMPLEST CASES HAVE BEEN
		DEALT WITH ALREADY.
INPUT:		XP1 POINTS TO ACTUAL PARAMETER NODE
OUTPUT:		X1 = (<qdt>B<%ZAPDTP>), WHERE qdt= QDTDYN OR QDTEXP.
;

	IFN <%ZAPDTP-%ZFLDTP>,<CFAIL CGPADT FAILURE>
CGPADT:	PROC
	LI	X1,(<QDTDYN>B<%ZFLDTP>)	;DYNAMIC ADDRESS IF
	LF	,ZNSKND(XP1)
	CAIN	QARRAY
	GOTO	L1	; VALUE FOR ARRAYS
	CAIE	QSIMPLE			;KIND IS NOT SIMPLE
	RETURN
	LF	,ZNSTYP(XP1)
	CAIN	QLABEL			;OR TYPE IS LABEL
	RETURN
	LF	,ZNSGEN(XP1)
	CAIE	%RP
	CAIN	%DOT
	RETURN
L1():	LI	X1,(<QDTEXP>B<%ZFLDTP>)	;OTHERWISE EXPRESSION
	RETURN
	EPROC
	SUBTTL	=== CGTHUNK ===

COMMENT;
PURPOSE:		COMPILE THUNK FOR AN ACTUAL PARAMETER POINTED TO BY XP1.
INPUT ASSERTION:	XP1 POINTS TO THE ACTUAL PARAMETER NODE.
OUTPUT ASSERTION:	A THUNK HAS BEEN COMPILED. THE DESCRIPTOR TYPE
			ZFLDTP OR ZAPDTP IS PLACED IN XV1 IN THE PROPER FIELD.
			XV1 IS OTHERWISE ZERO.
GENERATED CODE:		XWD displacement of thunk save area,0 or next ZAP address
			<code for thunk>
			JRST	@ZTSRAD(XCB)
;
CGTHUNK:PROC
	STACK	YACTAB
	IFOFF	SNOFML
	SOS	YTAC
	SUBI	XL1,(Z	1,)
	HRLM	XL1,YCGACT
	SETZM	YLXIAC
	L	YPAFIX
	GENFIX	;! XWD displacement of thunk save area,0 or next ZAP address !;
	IF
		IFON	STHUNK
		GOTO	FALSE
	THEN	;MUST ALLOCATE THUNK SAVE AREA
		SETON	STHUNK	;- BUT ONLY ONCE
		LI	X3,ZTS%S	;[7] Reserve space in display
		L	X1,YZHBXCB	;of XCB
		LOOP
			EXEC	CGUSTD
		AS	SOJG	X3,TRUE
		SA
	FI
	EXEC	CGPADT
	IF	CAIE	X1,(<QDTEXP>B<%ZFLDTP>)
		GOTO	FALSE
	THEN
		COMPVAL
		MOVSI	XV1,(<QDTEXP>B<%ZFLDTP>)
	ELSE
		COMPCA
		MOVSI	XV1,(<QDTDYN>B<%ZFLDTP>)
	FI
	LF	X1,ZNSKND(XP1)
	LF	X2,ZNSMOD(XP1)
	LF	X3,ZNSTYP(XP1)

	HRRZ	X4,YCGPAF
	EXEC	CGPA.T	;POSSIBLE RESTORE OF XSAC
	IF
		CAIN	X1,QPROCEDURE
		CAIN	X3,QLABEL
		GOTO	FALSE
	THEN
		IF	CAIE	X2,QDECLARED
			GOTO	TRUE
			IF	WHEN	XP1,ZID
				GOTO	FALSE
			THEN; REMOTE PROCEDURE
				LF	X1,ZNSZNO(XP1)
				STEP	X1,ZID
			ELSE; DECLARED PROCEDURE
				L	X1,XP1
			FI
			LF	X1,ZIDZQU(X1)
			LF	X1,ZQUZB(X1)
			LF	X1,ZHBNRP(X1)
			JUMPN	X1,FALSE
		THEN	;SPECIAL THUNK FOR PROCEDURE WITHOUT PARAMETERS
			LI	<OFFSET(ZTSRAD)>(X4)
			OP	(JSP	@(XCB))
			GENABS
			GPUSHJ	(CSSW)	;GET PROCEDURE VALUE ON RETURN
			SETZ		;DUMMY ACS MAP
			GENABS
			EXEC	CGPA.U	;UNCONDITIONAL XSAC RESTORE
	FI	FI
	LI	<OFFSET(ZTSRAD)>(X4)
	OP	(JSP	@(XCB))
	GENABS
	UNSTK	YACTAB
	ADDI	XL1,(Z	1,)
	HRLM	XL1,YCGACT
	IFOFF	SNOFML
	AOS	YTAC
	RETURN
	EPROC
	SUBTTL	=== CGFL ===

COMMENT;
PURPOSE:		COMPILE 1ST HALFWORD OF A ZFL TO Xtop.
INPUT ASSERTION:	X2 HAS ZFLDTP SET, OTHERWISE ZERO. XP1 POINTS TO ACTUAL
			PARAMETER NODE. XT=TYPE OF FORMAL PARAMETER.
;

CGFL:	PROC	;GENERATE 1ST HALFWORD OF ZFL IN X2 (ZFLDTP ALREADY SET)
CGFL1:	SETONA	ZFLNTH(X2)	;NO THUNK WHEN ENTERING HERE
CGFL2:	LF	X1,ZIDTYP(XP1)
	SF	X1,ZFLATP(,X2)
	SF	XT,ZFLFTP(,X2)
	IF	;Types are unequal
		CAIN	X1,(XT)
		GOTO	FALSE
	THEN	;[7] Error if QUICK procedure
		IF	IFOFF	SQUICK
			GOTO	FALSE
		THEN	L	X1,XL2	;[34] Identification of parameter
			STACK	X2
			LF	X2,CALLID	;Id no of procedure
			ERRI2	QE,<Q2.ERR+70>	;[34]
			UNSTK	X2
			L	[RTSERROR QDSCON,QSORCER]	;[41]
			GENABS
		FI
		SETONA	ZFLCNV(X2)
	FI
	LF	X1,ZIDKND(XP1)
	SF	X1,ZFLAKD(,X2)
	HLR	X2
	OP	(MOVSI)
	ADD	YCGACT
	GENABS	;! MOVSI Xtop, ZFL codes!;
	RETURN
	EPROC

COMMENT;
PURPOSE:		DEFINE, CLEAR AND REALLOCATE YPAFIX
;

CGPAFX:	PROC
	HRRZ	X1,YPAFIX
	DEFIX
	HRRZ	X1,YPAFIX
	CLFIX
	ALFIX
	HRRM	YPAFIX
	RETURN
	EPROC

COMMENT;
PURPOSE:		MAKE XSAC POINT TO THUNK SAVE AREA
;

CGPA.T:	PROC
	;; CONDITIONAL GENERATION OF INSTRUCTION TO RESTORE XSAC -
	;; CONDITION NOT YET DETERMINED
CGPA.U:	SAVE	<X1>
	LI	(X4)
	OP	(MOVEI	XSAC,(XCB))
	GENABS
	RETURN
	EPROC
	SUBTTL	=== CGZAP ===

COMMENT;
PURPOSE:		COMPUTE ZAP INSTANCE (ACTUAL PARAMETER DESCRIPTOR)
			FOR THE NODE POINTED TO BY XP1. EACH DESCRIPTOR
			IS FOLLOWED BY A LINK WORD,WHOSE LEFT HALF IS THE OFFSET
			OF THE LOCATION IN DISPLAY(XCB) WHERE THE OBJECT ADDRESS
			IS SAVED DURING PARAMETER EVALUATION.

;

CGZAP:	PROC
	SETZ	XV1,
	L	XP2,XP1
	EXEC	CGPA.F	;LOAD KIND, MODE, TYPE (XK, XM, XT)
	SF	XK,ZPDKND(,XV1)
	SF	XT,ZTDTYP(,XV1)
	IF	;TYPE REFERENCE, MUST HAVE QUALIFICATION
		CAIE	XT,QREF
		GOTO	FALSE
	THEN
		LF	X1,ZNSZQU(XP1)
		LF	,ZQUIND(X1)
		GENFIX		;! XWD 0,qualif. prototype !;
	FI
	EXEC	CGPAFX	;Define previous fixup, if any
	LF	X1,ZNOTYP(XP1)
	SETONA	ZAPNTH(XV1)	;ASSUME NO THUNK
	IF	;ZNO OR ZCN NODE
		CAIN	X1,QZNS
		GOTO	FALSE
	THEN
		IF	;CONSTANT
			CAIE	X1,QZCN
			GOTO	FALSE
		THEN
			TLO	XV1,(<QDTCON>B<%ZAPDTP>)
			L	X1,XT
			EXEC	CGPAGC
		ELSE	;MUST BE ZID
			ASSERT <WHENNOT XP1,ZID
				RFAIL	CGZAP MEMOP NOT ZID>
			IF	;[64] Array, name param, or simple but not label
				CAIE	XK,QARRAY	;[64]
				CAIN	XM,QNAME
				GOTO	TRUE
				CAIN	XT,QLABEL
				GOTO	FALSE
				CAIE	XK,QSIMPLE
				GOTO	FALSE
			THEN	;Make a NOTHUNK descriptor
				LI	X1,(<QDTVSI>B<%ZAPDTP>)
				CAIN	XM,QNAME
				LI	X1,(<QDTFNM>B<%ZAPDTP>)
				TLO	XV1,(X1)
				LF	X1,ZIDZQU(XP1)
				LF	X2,ZQUZHE(X1)
				LF	,ZHEDLV(X2)
				MOVN	;EBL CAN NOT BE USED FOR INSPECTED QUANT
				SF	,ZAPEBL(,XV1)
				LF	,ZQUIND(X1)
				HLL	XV1
				GENABS
			ELSE
				LI	X1,(<QDTDYN>B<%ZAPDTP>)
				GOTO	L2
			FI
		FI
		L	YPAFIX
		GENFIX		;CHAIN TO NEXT ZAP
	ELSE	;EXPRESSION
;[73] (Useless)	LF	XP2,ZNSZNO(XP1)
		EXEC	CGPA.F
		EXEC	CGPADT
	L2():!	TLO	XV1,(X1)
		SETOFA	ZAPNTH(XV1)	;INDICATE PRESENCE OF THUNK
		HRR	XV1,YRELCD	;THUNK ADDRESS
		ADDI	XV1,1
		L	XV1
		GENRLD		;ZAP
		EXEC	CGTHUNK
	FI
	IF	;LAST PARAMETER
		IFOFF	ZNOLST(XP1)
		GOTO	FALSE
	THEN
		EXEC	CGPAFX
		SETZ
		GENABS	;END OF CHAIN
	FI
	RETURN
	EPROC

	LIT
	RELOC
	VAR
	END