Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-05 - 43,50337/12/cgpa.mac
There are 2 other files named cgpa.mac in the archive. Click here to see a list.
00100		SUBTTL	Parameter handling on calling side
00200			sall
00300			comment;
00400	Author:		Lars Enderin 2-aug-73
00500	
00600	Version:	4 [7,24,31,34,47,64,73,111,212,340]
00700	
00800	Purpose:	Code  generation
00900	
01000	Contents:	Generators for nodes in expression tree:
01100	
01200			ZNS nodes %BEGPB, %NEW, %PCALL
01300	;
01400		SEARCH	SIMMAC,SIMMC2,SIMMCR,SIMRPA
01500		CTITLE	CGPA
01600	
01700		EXTERN	CAUS,CGAD,CGCA,CGCC,CGCO,CGVA,CGLO,CGLO1,CAUSTD
01800		EXTERN	YOPST
01900		EXTERN	CGRA,CGPD
02000	
02100		EXTERN	CADS,CAUD
02200		EXTERN	CGAS,CGG2,CGG3,CGG4,CGR2,CGR3,CGR4,CGSY
02300		EXTERN	O2AD,O2AF,O2GI
02400		EXTERN	CGIM,CGIM1,CGMO,CGMO1
02500		EXTERN	O2CF,O2DF,O2GA,O2GF,O2GR,O2GW,O2GWD,O2IV
02600		EXTERN	YCGFX1,YACTAB,YCGFX2,YLXIAC,YO2ADI,YO2ADF,YOPCOD
02700		EXTERN	YOPSTB,YOPSTP,YORFOR,YQRELR,YQRELT,YRELPT,YZHET,YRELCD
02800		EXTERN	YCGINS,YORACT,YORFX,YTAC,YZHBXC
02900		EXTERN	YGETAC,YRELAC ;[7]
03000	
03100		EXTERN	CABSTU,CGAC,CGRD,CGRN,CGCCCH
03200		EXTERN	YACTAB,YCGACT
03300		EXTERN	YCGPAF	;Switches only in left half
03400		EXTERN	YCGDBL,YPAFIX
03500	
03600	; COMPILE OPDEFS
03700	; ==============
03800		OPDEF	ALFIX	[PUSHJ	XPDP,O2AF] ;Allocate any free fixup no
03900		OPDEF	IFLR	[CAIE	X6,QLREAL] ;Skip if X6 = type code for long real
04000		OPDEF	LR	[CAIN	X6,QLREAL] ;Converse of IFLR
04100		OPDEF	OPAC	[OP	(XL1)]	   ;Modify val of index field by XL1
04200		OPDEF	OPZAC	[OPZ	(XL1)]	   ;Modify val of index field by XL1
04300		OPDEF	GENRLD	[PUSHJ	XPDP,CGRD]
04400	
04500	; MACROS
04600	DEFINE	FIRSTOP=<LF	XP1,ZNSZNO(XCUR)>
04700		MACINIT
04800		CGINIT
04900		TWOSEG
05000		RELOC	400K
05100	
05200	INTERN	.BEGPB,.NEW,.PCALL,CGACSA
05300	
05400	;SWITCHES
05500	;--------
05600	 DSW	STHUNK,YCGPAF,1,0	;On if any thunk for current parameter list
05700	 DSW	SNOFML,YCGPAF,0,0	;On if formals not known
05800	 DSW	SQUICK,YCGPAF,2,0	;[7] On for QUICK procedure
05900	
06000	;Local field definitions
06100	 DF CALLID,YCGPAF,12,17	;[7] Id no of called QUICK procedure
06200	
06300	 OPDEF	RH	[POINT	18,0,35]
06400	 RH==RH
06500	 DEFINE RIGHTHALF(A)<
06600	 IFN <RH-<<$'A>&<777777B17>>>,
06700	  <CFAIL	A IS NOT IN RH>>
06800	
06900	;Local register designations
07000	XK=X4	;(FORMAL) KIND
07100	XM=X5	;(FORMAL) MODE
07200	XT=X6	;(FORMAL) TYPE
     
00100		SUBTTL	=== BEGPB ===
00200	
00300	COMMENT;
00400	INPUT ASSERTION:	THE DECLARATIONS HAVE BEEN PROCESSED, AND THE
00500				BLOCK STACK INDICATES THE PREF BLK AS THE CURRENT ONE.
00600				XZHE POINTS TO THE ZHE OF THE PBLOCK.
00700	
00800	GENERATED CODE:		MOVEI	XSAC,prefixed block prototype
00900				PUSHJ	XPDP,CPSP
01000				<Transmit any parameters>
01100	;
01200	
01300	.BEGPB:	LF	,ZHEFIX(XZHE)	;Prototype fixup no
01400		OP	(MOVEI	XSAC,)
01500		GENFIX
01600		GPUSHJ	CPSP
01700		LF	XP1,ZNSZNO(,YOPST) ;Get ZID node of class
01800		IFOFF	ZNOLST(XP1)	;Has parameters if this is not the last node
01900		 XEC	CGPARM
02000		L	X1,YZHET
02100		LF	X1,ZHEFIX(X1)	;Define FIX+2 (start of decl coding)
02200		LI	X1,2(X1)
02300		DEFIX
02400		EXEC	CAUSTD		;Update display index
02500		RETURN
     
00100		SUBTTL	=== NEW ===
00200	
00300	COMMENT;
00400	INPUT ASSERTION:	XCUR POINTS TO A %NEW NODE (ZNS).
00500				THE FIRST OPERAND IS THE ZID OF THE CLASS.
00600	GENERATED CODE:		:IF ANY RESULTS MUST BE SAVED:
00700				[PUSHJ	XPDP,CSSA
00800				XWD	no. of intermediate results,address of acs map]
00900				PUSHJ	XPDP,CPNE
01000				XWD	display offset,class prototype
01100				<transfer any parameters and enter>
01200	;
01300	
01400	.NEW:	FIRSTOP
01500		;[47]
01600		LF	X2,ZIDZQU(XP1)
01700		LF	X1,ZQUZB(X2)
01800		;CHECK IF SIMULATION OR SIMSET IN PREFIX CHAIN
01900		LOOP
02000			IF	;System class
02100				IFOFF	ZQUSYS(X2)
02200				GOTO	FALSE
02300			THEN
02400				IF	;Simulation or Simset
02500					LF	X0,ZQULID(X2)	;IDENTIFIER NUMBER
02600					CAIN	X0,QIDSIM
02700					GOTO	TRUE		;ERROR
02800					CAIE	X0,QIDSET
02900					GOTO	FALSE		;OK
03000				THEN	;Generate error message at compile- and run-time
03100					LF	X2,ZIDZQU(XP1)
03200					LF	X1,ZQULID(X2)
03300					ERRI1	QE,423	;NEW XXXX IS AN ILLEGAL OBJECT GENERATOR
03400					L	[RTSERR QDSCON,QSORCER]
03500					GENABS
03600					GOTO	.NEW01
03700				FI
03800			FI
03900		AS
04000			;CHECK IF PREFIX EXIST
04100			LF	X1,ZHBZHB(X1)	
04200			JUMPE	X1,FALSE		;NO MORE PREFIX
04300			LF	X2,ZHBZQU(X1)
04400			GOTO	TRUE
04500		SA
04600		
04700		;[47] END
04800		GETAC2
04900		EXEC	CGACSA	;CODE TO SAVE ACS, IF ANY
05000		GPUSHJ	(CPNE)
05100		LF	X2,ZIDZQU(XP1)	;ZQU of class
05200		IF	;[111] Class decl AND its declaring block are both
05300			;      visible by connection
05400			IFOFF	ZQUIS(X2)
05500			GOTO	FALSE
05600			LF	X3,ZQUZHE(X2)
05700			LF	X1,ZHBZQU(X3)
05800			IFOFF	ZQUIS(X1)
05900			GOTO	FALSE
06000		THEN	;Use DLV of declaring block
06100			LFE	X1,ZHEDLV(X3)
06200		ELSE	;Use SBL of the class itself
06300			LF	X1,ZQUZB(X2)
06400			LF	X1,ZHBSBL(X1)
06500			MOVN	X1,X1
06600		FI	;[111]
06700		LF	,ZQUIND(X2)	;PROTOTYPE FIXUP
06800		HRL	X1		;DISPLAY OFFSET
06900		GENFIX			;XWD	display offset,prototype of class
07000		IFOFF	ZNOLST(XP1)
07100		 XEC	CGPARM		;Handle parameters
07200		RELAC2
07300	.NEW01:	;[47]
07400		RETURN
     
00100		SUBTTL	CGACSA - code to save intermediate results
00200	
00300	COMMENT;
00400	PURPOSE:	TO GENERATE CODE TO SAVE INTERMEDIATE RESULTS, IF ANY
00500	GENERATED CODE:	(ONLY IF NECESSARY)
00600			PUSHJ	XPDP,CSSA
00700			XWD	number of intermediate results, address of map
00800	;
00900	CGACSA:	PROC
01000		SAVE	X1
01100		HRRZ	YTAC
01200		IF	;More than one ac on stack
01300			CAIN	YACTAB
01400			GOTO	FALSE
01500		THEN	;Emit code to save ac's in ZAC object
01600			GPUSHJ	CSSA
01700			EXEC	CGAC
01800		FI
01900		SETZM	YLXIAC	;Must assume XIAC destroyed after call
02000		RETURN
02100		EPROC
     
00100		SUBTTL	=== PCALL ===
00200	
00300	COMMENT;
00400	INPUT ASSERTION:	NODE %PCALL WITH OPERANDS:
00500				ZID/ZNS NODE,FOLLOWED BY ANY PARM NODES WITH ACTUAL AND
00600				FORMAL PARAMETER NODES AS SUBNODES.
00700	
00800	GENERATED CODE:		(1) SIMPLE CASE - STATICALLY VISIBLE PROCEDURE:
00900				:IF ANY RESULTS MUST BE SAVED:
01000				[PUSHJ	XPDP,CSSA
01100				XWD	no. of intermediate results,address of acs map]
01200				MOVEI	XSAC,procedure prototype
01300				PUSHJ	XPDP,CSSN
01400				[parameter transmission and procedure entry]
01500	
01600				(2) MORE COMPLICATED CASES - PROC IN INSPECTED
01700				CLASS, REMOTE, FORMAL, VIRTUAL OR NOCHECK PROCEDURE:
01800				compute ZDP of procedure to XWAC1 & XWAC2
01900				PUSHJ	XPDP,CSSW   or   PUSHJ XPDP,CSSW0
02000				XWD	no. of intermediate results,address of acs map
02100				[parameter transmission and procedure entry]
02200	;
02300	
02400	.PCALL:	PROC
02500		FIRSTOP
02600		IF
02700			RECTYPE(XP1) IS ZID
02800			GOTO	FALSE
02900			LF	X1,ZIDZQU(XP1)
03000			LF	X2,ZIDMOD(XP1)
03200			CAIE	X2,QDECLARED	;DECLARED
03300			GOTO	FALSE
03400			LF	X2,ZQUZB(X1)
03500			JUMPE	X2,FALSE
03600		THEN	;Normal case (unless NOCHECK or inspection)
03700			JSP	X3,CGQIQS	;[7] Check for QUICK or sys calling sequence
03705						edit(340)
03710			IFON ZQUIS(X1)	;[320] Inspected not QUICK or SYS
03720			 GOTO L2	;[340]
03800			IFON	ZHBNCK(X2)	;[7]
03900			 GOTO	L2		;[7]
04000			EXEC	CGACSA		;Save any intermediate results
04100			LF	X1,ZIDZQU(XP1)	;------------------------;
04200			LF	,ZQUIND(X1)	; MOVEI XSAC,proc. prot. ;
04300			OP	(MOVEI	XSAC,)	; PUSHJ XPDP,CSSN	 ;
04400			GENFIX			;------------------------;
04500			GPUSHJ	CSSN
04600		ELSE
04610			JSP X3,CGQIDOT	;[340]
04700			JSP	X3,CGQISY	;[7] Check for sys calling sequence
04800					;-------------------------------------------;
04900	L2():!		COMPVAL	;[7]  	; Dyn addr of procedure to XWAC1+n, XWAC2+n ;
05000	
05100			;[24] Generate PUSHJ  XPDP,CSSW0  for formal or virtual
05200			;  procedure calls without parameter list
05300	
05400			IF
05500				IFEQF	(XP1,ZIDMOD,QDECLARED)
05600				GOTO	FALSE
05700				IFOFF	ZNOLST(XP1)
05800				GOTO	FALSE
05900			THEN
06000						;-------------------------------;
06100				GPUSHJ	CSSW0	; PUSHJ XPDP,CSSW0		;
06200						;-------------------------------;
06300			ELSE
06400						;-----------------------------------;
06500				GPUSHJ	CSSW	; PUSHJ	XPDP,CSSW		    ;
06600						;-----------------------------------;
06700			FI
06800	
06900					;-------------------------------------------;
07000			EXEC	CGAC	; XWD	n,admap				    ;
07100					;-------------------------------------------;
07200		FI
07300		IFOFF	ZNOLST(XP1)
07400		 XEC	CGPARM		;Handle parameters
07500		RELAC2
07600		EXEC	CGCCCH		;Possible SKIP instr if part of conditional
07700		RETURN
07800		EPROC
07900	
08000	
08100	CGQIQS:	LF	,ZHBMFO(X2)	;[7]
08200		CAIN	QEXMQI		;[7] QUICK procedure?
08300		 BRANCH	CGQI		;[7] Treat specially
08400	CGQISY:	IFON	ZQUSYS(XP1)	;[7]
08500		 BRANCH	CGSY		;[7] System procedure
08600		GETAC2			;[7]
08700		BRANCH	(X3)		;[7] RETURN
     
00100		SUBTTL CGQIDOT, possible call on QUICK procedure attribute
00200	
00300	CGQIDOT: edit(340)		;Call via JSP X3,CGQIDOT
00400		LF ,ZNSGEN(XP1)		;Generator for ZNS node
00500		CAIE %DOT		; must be %DOT
00600		 BRANCH (X3)
00700		
00800		LF X2,ZNSZNO(XP1)	;First operand (<reference>)
00900		STEP X2,ZNS		;2nd operand (proc id)
01000		LF X1,ZIDZQU(X2)
01100		LF X2,ZQUMOD(X1)	;Mode must be declared
01200		JUMPN X2,(X3)
01300		
01400		LF X2,ZQUZB(X1)		;ZHB
01500		JUMPE X2,(X3)
01600		
01700		LF ,ZHBMFO(X2)		;CODE, QUICK, FORTRAN, F40, SIMULA
01800		CAIE QEXMQI		;Only QUICK interesting now, but
01900		 BRANCH (X3)		; also FORTRAN, F40, CODE could be
02000					; treated specially (no need for ref)
02100		STACK XP1
02200		LF XP1,ZNSZNO(XP1)	;Pick out node for reference expr
02300		COMPVAL			;Compute (and discard) its value
02500		STEP XP1,ZNS,X3		;X3:- proc id node
02550		UNSTK XP1
02600		LD X1,(X3)		;Move it to where %DOT node was
02700		IFOFF ZNOLST(XP1)	; with ZNOLST off if parameters exist
02800		 SETOFA ZNOLST(X1)
02900		STD X1,(XP1)
03000		LF X1,ZIDZQU(XP1)	;Need to have X2:- ZHB
03100		LF X2,ZQUZB(X1)
03200		BRANCH CGQI		;Handle as if <reference> did not exist
     
00100		SUBTTL	[7] === CGQI === [7]
00200	
00300	Comment/
00400	Input assertion:
00500		XP1 points to a ZID node for an external MACRO-10
00600		procedure which should have a special quick calling
00700		sequence similar to the calling sequences of Outtext,
00800		Histo, Inint etc., i e parameters are passed in
00900		successive registers, normally starting with XWAC1.
01000		X1 :- ZIDZQU(XP1), X2:-ZQUZB(X1).
01100	Generated code:
01200	(1)	Compute parameters to successive ac's starting with Xtop.
01300	(2a)	;(with CHECK option):
01400		MOVEI	XTAC,Xtop	;Only for <type> procedure
01500	(2b)	;(NOCHECK):
01600		SKIPA	XTAC,.+1
01700		XWD	-n, Xtop	;n = number of actual parameters
01800	;or if n = 0:
01900		MOVEI	XTAC,Xtop
02000	(3)	PUSHJ	XPDP,entry
02100	/
02200	
02300	CGQI:	PROC
02400		IF	;Parameters are checked
02500			IFON	ZHBNCK(X2)
02600			GOTO	FALSE
02700		THEN
02800			LF	X3,ZHELEN(X2)	;Number of ac's needed = block length
02900			IF	;Any ac's needed
03000				JUMPLE	X3,FALSE
03100			THEN	;Compute parameters to successive ac's
03200				EXEC	CGQIPA
03300			FI
03400			LF	X1,ZIDZQU(XP1)
03500			LF	,ZQUTYP(X1)
03600			IF	;Type procedure (function)
03700				CAIN	QNOTYPE
03800				GOTO	FALSE
03900			THEN	;Tell the function which is the top ac
04000				HRRZ	@YTAC
04100				OP	(MOVEI	XTAC,)
04200				GENABS
04300			FI
04400		ELSE	;NOCHECK procedure
04500			IF	;No parameters given
04600				IFOFF	ZNOLST(XP1)
04700				GOTO	FALSE
04800			THEN	;Simple calling seq
04900				STACK	[0]	;Number of parameters
05000			ELSE	;Compute parameters
05100				STEP	XP1,ZNS,X1
05200				EXEC	CGPANO
05300				STACK	X0	;Number of parameters
05400				L	X3,X0
05500				ADD	X3,X0	;Twice as many ac's needed
05600				IF	;[34] Too many
05700					CAIG	X3,QNAC
05800					GOTO	FALSE
05900				THEN	;Error
06000					L	X1,X3
06100					ERRI1	QE,<Q2.ERR+66>
06200					L	[RTSERR QDSCON,QSORCER]	;[41]
06300					GENABS
06400				ELSE	;Handle parameters
06500					LF	X1,ZIDZQU(XP1)	;[34] Restore X1
06600					EXEC	CGQIPA
06700				FI	;[34]
06800			FI
06900			UNSTK	X1	;Number of parameters
07000			IF	;There were any
07100				JUMPE	X1,FALSE
07200			THEN	;We need two instructions
07300				LI	1
07400				ADD	YRELCD
07500				OP	(SKIPA	XTAC,)
07600				GENRLD			;[SKIPA XTAC,.+1]
07700				MOVN	X1
07800				HRLZ
07900			ELSE	;Just one instruction
08000				OP	(MOVEI	XTAC,)
08100			FI
08200			HRR	@YTAC		;Xtop
08300			GENABS			;[XWD -n,Xtop] or [MOVEI XTAC,Xtop]
08400		FI
08500		LF	X1,ZIDZQU(XP1)	;Generate PUSHJ to procedure entry
08600		LF	,ZQUIND(X1)	;Fixup for entry point
08700		OP	(PUSHJ XPDP,)
08800		GENFIX
08900		SETZM	YLXIAC		;XIAC will probably be destroyed
09000		EXEC	CGCCCH		;Possible skip instr if part of conditional
09100		RETURN
09200		EPROC
     
00100		SUBTTL	=== CGQIPA ===  [7]
00200	
00300	Comment;
00400	
00500	Purpose:		To compute parameters to successive ac's for a call on
00600				a "QUICK" external procedure.
00700	Input assertion:	XP1 points to ZID of procedure, followed by a
00800				parameter list, consisting of %PARM nodes,
00900				each with an actual/formal parameter node pair as
01000				subnodes. X3 has number of ac's needed for parameters.
01100				X1 :- ZIDZQU of procedure. X2:-ZQUZB(X1).
01200	Code generated:		Actual parameter computation to ac's.
01300	;
01400	
01500	CGQIPA:	PROC
01600		SAVE	<XP2,XV1,XV2,XL1,XL2>	;[34]
01700		SETZM	YLXIAC	;Make sure XIAC is reloaded when needed
01800		STACK	YCGDBL
01900		STACK	YCGPAF
02000		HRRZS	YCGPAF		;Reset switches
02100		SETON	SQUICK
02200		IFON	ZHBNCK(X2)	;[34]
02300		SETON	SNOFML
02400		LF	,ZQULID(X1)	;Get lexical id of proc to use in case of error
02500		SF	,CALLID
02600		XCT	YGETAC-1(X3)	;Reserve ac's for all parameters
02700		STACK	YTAC		;Save YACTAB status
02800		STEP	XP1,ZNS,XP2	;XP2:-first %PARM node
02900		LI	XL2,QLOWID	;[34] Signifies parameter number: 1
03000		LOOP
03100			EXEC	CGPA.1
03200		AS	IFON	ZNOLST(XP2)
03300			GOTO	FALSE
03400			STEP	XP2,ZNS
03500			AOJA	XL2,TRUE	;[34] Count parameters
03600		SA
03700		UNSTK	YTAC
03800		XCT	YRELAC		;Let go of ac's
03900		UNSTK	YCGPAF
04000		UNSTK	YCGDBL
04100		RETURN
04200		EPROC
     
00100		SUBTTL	=== CGPARM ===
00200	
00300	COMMENT;
00400	
00500	PURPOSE:		TRANSMITS PARAMETERS TO CLASSES, PREFIXED BLOCKS
00600				AND PROCEDURES.
00700	
00800	INPUT ASSERTION:	XP1 POINTS TO ZID OF PROCEDURE OR CLASS, FOLLOWED
00900				BY A PARAMETER LIST, CONSISTING OF %PARM NODES,
01000				EACH WITH ACTUAL/FORMAL SUBNODES, OR, FOR PARAMETERS
01100				TO FORMAL OR VIRTUAL PROCEDURES, AN ACTUAL PARAM. LIST.
01200				THE ADDRESS OF THE OBJECT HAS BEEN COMPUTED TO XWAC1
01300				BY CSSN, CSSW, CPNE OR CPSP.
01400	
01500	CODE GENERATED:		<parameter transmission>
01600				PUSHJ	XPDP,CSEN
01700	;
01800	
01900	CGPARM:	PROC
02000		SAVE	<XP2,XV1,XV2,XL1>
02100		EXEC	CGPD		;Save ac stack description, start over
02200		SETZM	YLXIAC		;Make sure XIAC is reloaded when needed
02300		STACK	YCGPAF		;Save recursion data
02400		STACK	YCGDBL
02500		STACK	YPAFIX
02600		L	X1,YZHBXCB
02700		LF	,ZHBSTD(X1)	;SAVE CURRENT STD
02800		MOVN	X2,		;IN MORE USEFUL FORM (NEGATED)
02900		HRRZM	X2,YCGPAF	;SWITCHES IN LEFT HALF ARE RESET
03000	;[7]	EXEC	CGUSTD
03100		STEP	XP1,ZNS,XP2
03200		IF	;ZNS(%PARM)
03300			WHENNOT(XP2,ZNS)
03400			GOTO	FALSE
03500			IFNEQF(XP2,ZNSGEN,%PARM)
03600			GOTO	FALSE
03700		THEN
03800			LI	[BYTE	(6)QZNS(2)0(4)QREF(3)QDECLARED(3)QSIMPLE
03900				0]
04000			; THE LITERAL ABOVE IS A DUMMY ZNS NODE USED TO
04100			; DESCRIBE THE RETURNED PROCEDURE INSTANCE IN XWAC1
04200			HRLM	@YTAC	;Update YTAC
04300			AOS	YTAC
04400			SETOFF	SNOFML
04500		ELSE	;Only actual parameters known
04600			L	X1,XP2
04700			EXEC	CGPANO	;Count parameters in X0
04800			GENABS		;NUMBER OF PARAMETERS (Z  n)
04900			GPUSHJ	(PHPT)
05000			SETON	SNOFML	;No formals known
05100		FI
05200		ALFIX		;ALLOCATE FIXUP FOR SKIPPING THUNKS
05300		HRL	YCGPAF
05400		ST	YPAFIX	;offset of object save loc,,fixup no.
05500		LOOP	;For each actual parameter
05600			EXEC	CGPA.1
05700		AS
05800			IFON	ZNOLST(XP2)
05900			GOTO	FALSE
06000			STEP	XP2,ZNS
06100			GOTO	TRUE
06200		SA
06300	
06400		GPUSHJ	CSEN
06500		L	X1,YZHBXCB
06600		MOVN	YCGPAF
06700		SF	,ZHBSTD(X1)
06800		HRRZ	X1,YPAFIX
06900		CLFIX
07000		UNSTK	YPAFIX
07100		UNSTK	YCGDBL
07200		UNSTK	YCGPAF
07300		EXEC	CGRA	;Restore old ac stack description (YACTAB)
07400		RETURN
07500		EPROC
07600	
07700	
07800	CGPANO:	;Count parameters starting at (X1)
07900		LI	1	;Count in X0
08000		LOOP
08100			HLL	X1,OFFSET(ZNOLST)(X1)
08200			ADDI	X1,ZNO%S
08300		AS	;long as we have more parameters
08400			IFOFFA	ZNOLST(X1)
08500			AOJA	TRUE
08600		SA
08700		RETURN
     
00100		SUBTTL	CGPA.R,CGUSTD,CGNQ
00200	
00300	REPEAT 0,<
00400	CGPA.R:	PROC	;RECOVER POINTER TO CLASS/PROC/PBLK INSTANCE
00500			;X2 HOLDS NUMBER OF AC TO GET THE OBJECT ADDRESS
00600		HRRZ	YCGPAF
00700		OP	(HLRZ	(XCB))
00800		DPB	X2,[ACFIELD]
00900		GENABS
01000		LI	X2,XWAC1
01100		RETURN
01200		EPROC
01300	>
01400	
01500	CGUSTD:	PROC	;INCREASE STD BY 1, POSSIBLY UPDATE SZD (MAX STD VALUE)
01600			;X1 POINTS TO ZHB. X2 IS DESTROYED.
01700		SIZE	(QMS,ZHBSTD)
01800		LF	,ZHBSTD(X1)
01900		LF	X2,ZHBSZD(X1)
02000		ADDI	1
02100		 CAIL	<1_<QMS>>
02200		ERROR2	50,DISPLAY SIZE OVERFLOW
02300		CAMLE	X2
02400		SF	,ZHBSZD(X1)
02500		SF	,ZHBSTD(X1)
02600		RETURN
02700		EPROC
02800	
02900	CGNQ:	;Set ZFLZQU for id or expression of type REF
03000		LF	,ZNSTYP(XP1)
03100		CAIE	QREF
03200		RETURN
03300		LF	X1,ZNSZQU(XP1)
03400		WHEN	(XP1,ZNN)	;[1]	If thunk was compiled
03500		LF	X1,ZNNZQU(XP1)	; use ZNNZQU instead of ZNSZQU
03600		LF	,ZQUIND(X1)	;Fixup for qualif. prototype
03700		OPAC	(HRLI	1,)
03800		GENFIX			;! HRLI Xtop+1,qualif. prototype !;
03900		RETURN
     
00100		SUBTTL	=== CGPA.1 ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE CODE TO HANDLE TRANSMISSION OF ONE
00500				PARAMETER TO A CLASS,PROCEDURE OR PREFIXED BLOCK.
00600	INPUT ASSERTION:	XP2 POINTS TO THE CURRENT %PARM NODE, OR IF ONLY
00700				ACTUAL PARAMETERS ARE KNOWN,XP2 POINTS TO 
00800				THE FIRST ACTUAL PARAMETER.
00900	
01000	;
01100	
01200	CGPA.1:	PROC
01300		SAVE	XP2
01400		STACK	XP1
01500		HRRZ	XL1,@YTAC	;[7] Prepare for OPAC, OPZAC
01600		LSH	XL1,5		;[7]
01700		HRLM	XL1,YCGACT	;[7]
01800		SETZM	YCGDBL
01900		IF	;FORMAL PARAMETER NOT KNOWN AT COMPILE TIME
02000			IFOFF	SNOFML
02100			GOTO	FALSE
02200		THEN
02300			L	XP1,XP2
02400			IF	;[7] not QUICK
02500				IFON	SQUICK
02600				GOTO	FALSE
02700			THEN	EXEC	CGZAP
02800				UNSTK	XP1	;[7]
02900			ELSE	;[7] QUICK, fake formal node
03000				EXEC	CGPA.F	;Kind (XK), mode (XM), type (XT)
03100				GOTO	L1
03200			FI	;[7]
03300		ELSE
03400			LF	XP1,ZNSZNO(XP2)	;XP1:-ACTUAL PARM NODE
03500			STEP	XP1,ZNS,XP2	;XP2:-FORMAL NODE
03600			EXEC	CGPA.F		;FORMAL(KIND, MODE, TYPE) TO (XK, XM, XT)
03700			IF	;VALUE mode
03800				CAIE	XM,QVALUE
03900				GOTO	FALSE
04000			THEN
04100				EXEC	CGPV
04200			ELSE
04300			IF	;REFERENCE mode
04400				CAIE	XM,QREFERENCE
04500				GOTO	FALSE
04600			THEN
04700				IF	;NOT AN ARRAY
04800					CAIN	XK,QARRAY
04900					GOTO	FALSE
05000				THEN
05100					IF	;KIND PROCEDURE
05200						CAIE	XK,QPROCEDURE
05300						GOTO	FALSE
05400					THEN	;TWO WORDS DYNAMIC ADDRESS EXCEPT FOR SWITCH
05500						CAIE	XT,QLABEL
05600						AOS	YCGDBL
05700					ELSE	;TWO WORDS FOR SIMPLE TEXT OR LABEL
05800						CAIE	XT,QTEXT
05900						CAIN	XT,QLABEL
06000						AOS	YCGDBL
06100					FI
06200				FI
06300				COMPVAL
06400			ELSE	;--- MUST BE BY NAME, THEN ---
06500				ASSERT <CAIE	XM,QNAME
06600					RFAIL	NONEXISTENT MODE>
06700		L1():!		IFON	SQUICK	;[73] Must have correct YACTAB reference
06800				HRLM	XP1,@YTAC;(No COMPxxx proc will be called to do this)
06900				EXEC	CGPN
07000			FI	FI
07100			UNSTK	XP1	;[7]
07200			IF	;[7] Normal case
07300				IFON	SQUICK
07400				GOTO	FALSE
07500			THEN	;[7]
07600				;--- MOVE PARAMETER TO FORMAL POSITION.
07700				;--- USE NEXT FREE AC FOR THE OBJECT ADDRESS
07800				L	X3,@YTAC
07900				LI	X2,XWAC1
08000				LF	X1,ZIDZQU(XP2)
08100				LF	,ZQUIND(X1)
08200				OP	(MOVEM)
08300				SKIPE	YCGDBL
08400				KA10WARNING
08500				OP	(DMOVEM)
08600				DPB	X2,[INDEXFIELD]
08700				DPB	X3,[ACFIELD]
08800				GENABS
08900			ELSE	;[7] Leave parameter in ac(s)
09000				IF	;[73] Name mode transmission
09100					LF	XM,ZIDMOD(XP2)
09200					CAIN	XM,QNAME
09300					GOTO	TRUE
09400					IFOFF	SNOFML
09500					GOTO	FALSE
09600				THEN	;Change node to ZNN node for "computed addr"
09700					;This is to arrange for correct ac map when
09800					;necessary for following parameter evaluations
09900					HLRZ	X1,@YTAC
10000					LI	ZNN%V
10100					SF	,ZNOTYP(X1)
10200					LI	QCODCA
10300					SF	,ZNNCOD(X1)
10400				FI	;[73]
10500				AOS	YTAC
10600				SKIPE	YCGDBL
10700				AOS	YTAC
10800			FI	;[7]
10900		FI
11000		RETURN
11100		EPROC
     
00100		SUBTTL	=== CGPN ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE ZFL TO Xtop & Xtop+1.
00500				A THUNK IS COMPILED IF NECESSARY.
00600	INPUT ASSERTION:	THE FORMAL PARAMETER IS KNOWN AND SPECIFIED NAME.
00700				XP1 POINTS TO THE ACTUAL PARAMETER NODE.
00800	;
00900	
01000	CGPN:	PROC
01100		ASSERT	<RIGHTHALF ZFLZBI>
01200		AOS	YCGDBL		;ALWAYS TWO WORDS FOR NAME PARAMETER
01300		L	X3,@YTAC
01400		LF	,ZNOTYP(XP1)	;[64] Node type
01500		CAIN	QZNS	;[31]
01600		BRANCH	CGNX	;[31] ZNS node implies expression
01700	;--- CHECK FOR CONSTANT PARAMETER ---
01800		CAIN	QZCN
01900		BRANCH	CGNC
02000	;--- CHECK FOR NAME PARAMETER AS ACTUAL PARAMETER ---
02100		LF	X1,ZIDMOD(XP1)
02200		CAIN	X1,QNAME
02300		BRANCH	CGNN
02400		ASSERT	<
02500		CAIE	QZID	;[64] If not ZID node here, something is fishy
02600		RFAIL	CGPN not ZID
02700		>
02800	;--- CHECK IF ZID NODE NEEDS THUNK ---
02900		LF	,ZIDKND(XP1)
03000		LF	X1,ZIDTYP(XP1)
03100		;PROCEDURE, SWITCH OR LABEL
03200		CAIE	QPROCEDURE 
03300		CAIN	X1,QLABEL
03400		BRANCH	CGNX
03500	;--- SIMPLE TYPE OF DESCRIPTOR HERE ---
03600		BRANCH	CGNS
03700		EPROC
     
00100		SUBTTL	=== CGPV ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE VALUE OF PARAMETER TO Xtop & Xtop+1.
00500	INPUT ASSERTION:	XP1 POINTS TO AN ACTUAL PARAMETER NODE. THE
00600				CORRESPONDING FORMAL PARAMETER IS SPECIFIED VALUE.
00700				TYPE AND KIND OF FORMAL ARE IN XK,XT.
00800	;
00900	
01000	CGPV:	PROC
01100		IF	;Simple value type
01200			CAIG	XT,QBOOLEAN
01300			CAIE	XK,QSIMPLE
01400			GOTO	FALSE
01500		THEN	;Compute the value
01600			CAIN	XT,QLREAL
01700			AOS	YCGDBL
01800			COMPVAL
01900		ELSE
02000		IF	;ARRAY
02100			CAIE	XK,QARRAY
02200			GOTO	FALSE
02300		THEN	;Use CSCA with inline acs descriptor ;[7]
02400			COMPVAL
02500			GPUSHJ	(CSCA)	;COPY ARRAY OBJECT
02600			EXEC	CGAC	;[n,,admap]
02700		ELSE
02800		IF	CAIE	XT,QTEXT
02900			GOTO	FALSE
03000		THEN
03100			AOS	YCGDBL
03200			COMPVAL
03300			GPUSHJ	(TXCY)	;COPY THE TEXT OBJECT
03400			EXEC	CGAC	;[7] XWD n,admap
03500		ASSERT<
03600		ELSE
03700			RFAIL	<REF LABEL OR NOTYPE ILLEGAL BY VALUE>
03800		>
03900		FI	FI	FI
04000		RETURN
04100		EPROC
     
00100		SUBTTL	=== CGNN ===
00200	
00300	COMMENT;
00400	PURPOSE:		TO GENERATE CODE FOR PASSING A NAME PARAMETER
00500				TO A PROCEDURE, WHEN THE ACTUAL PARAMETER IS ALSO
00600				SPECIFIED BY NAME ON THE CALLING SIDE
00700	INPUT ASSERTION:	X3=Xtop
00800	;
00900	
01000	CGNN:	PROC
01100		LF	X1,ZIDZQU(XP1)
01200		GETAD
01300		OPZ	(DMOVE)
01400		ST	YOPCOD
01500		GENOP
01600		LF	X2,ZIDTYP(XP1)
01700		IF	;ACTUAL TYPE =/= FORMAL TYPE
01800			CAIN	XT,(X2)
01900			GOTO	FALSE
02000		THEN	;MODIFY ZFLFTP, ZFLCNV
02100		;! MOVEI Xtop+2,formal type code !;
02200			L	XT
02300			OPAC	(MOVEI	2,)
02400			GENABS
02500		;! DPB	Xtop+2,[$ZFLCTP(,Xtop)] !;	CNV BIT CLEARED WITH ZFLFTP
02600			MOVSI	($ZFLCTP)	;[212]
02700			ADDI	(X3)		;[212]
02800			GENWRD
02900			OPAC	(DPB	2,)
03000			GENREL
03100		;! LDB	Xtop+3,[$ZFLATP(,Xtop)] !;
03200			MOVSI	($ZFLATP)	;[212]
03300			ADDI	(X3)		;[212]
03400			GENWRD
03500			OPAC	(LDB	3,)
03600			GENREL
03700		;! CAIE	Xtop+3,formal type code !;
03800			L	XT
03900			OPAC	(CAIE	3,)
04000			GENABS
04100		;! TLO	Xtop,(1B<%ZFLCNV>) !;
04200			LI	(1B<%ZFLCNV>)
04300			OPAC	(TLO)
04400			GENABS
04500		FI
04600		IF	;[7] QUICK procedure
04700			IFOFF	SQUICK
04800			GOTO	FALSE
04900		THEN	;Must guard against unequal types or thunk
05000			LI	(1B<%ZFLCNV>)
05100			OPAC	(TLNN)	;! TLNN Xtop,(1B<%ZFLCNV>)
05200			GENABS
05300			LI	(1B<%ZFLNTH>)
05400			OPAC	(TLNN)	;! TLNN	Xtop,(1B<%ZFLNTH>)
05500			GENABS
05600			L	[RTSERROR 102] ;Complicated parameter to QUICK proc
05700			GENABS
05800		FI	;[7]
05900		RETURN
06000		EPROC
     
00100		SUBTTL	=== CGNS ===
00200	COMMENT;
00300	PURPOSE:		COMPILE ZFL TO Xtop & Xtop+1 FOR SIMPLE VARIABLE,
00400				ARRAY OR TEXT.
00500	INPUT ASSERTION:	XP1 POINTS TO A ZID NODE WHICH IS NOT FOR A PROCEDURE,
00600				LABEL OR SWITCH.
00700	CODE GENERATED:		MOVSI	Xtop,ZFL flags
00800				HRR	Xtop,display displ. of declaring block(XCB)
00900				MOVEI	Xtop+1,offset of actual parameter in its block
01000				For a REF quantity:
01100				HRLI	Xtop+1,prototype address
01200	;
01300	
01400	CGNS:	PROC
01500		MOVSI	X2,(<QDTVSI>B<%ZFLDTP>)
01600		EXEC	CGFL1
01700		;Code to load block instance of parameter from display of XCB
01800		; (or from Sysout pointer)
01900		LF	X2,ZIDZQU(XP1)		;Quant for id
02000		LF	X1,ZQUZHE(X2)		;Enclosing blk hdr
02100		LF	,ZHEDLV(X1)		;Display element offset
02200			edit(321)
02300		IF	;[321] BASICIO	(offset=0)
02400			JUMPN FALSE
02500		THEN	;Should be (Sysout.) Image
02600			L [LOWADR(XSAC)]	;! LOWADR XSAC		!;
02700			GENABS
02800			LI YSYSOUT		;! HRR Xtop,YSYSOUT(XSAC) !;
02900			OPAC (HRR (XSAC))
03000		ELSE	;Ordinary variable
03100			OPAC	(HRR	(XCB))	;! HRR Xtop,display level(XCB) !;
03200		FI
03300		GENABS
03400		LF	,ZQUIND(X2)		; offset in block
03500		OPAC	(MOVEI	1,)
03600		GENABS	;! MOVEI Xtop+1,offset of actual parameter !;
03700		BRANCH	CGNQ	;Compile ZFLZQU if REF
03800		EPROC
     
00100		SUBTTL	=== CGNC ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE FORMAL LOCATION FOR CONSTANT
00500	INPUT ASSERTION:	XP1 POINTS TO ZCN NODE FOR THE ACTUAL PARAMETER
00600	CODE GENERATED:		MOVSI	Xtop,ZFL flags
00700				MOVEI	Xtop+1, address of constant
00800	;
00900	CGNC:	PROC
01000		OPZAC	XV1,(MOVEI 1,)
01100		MOVSI	X2,(<QDTCON>B<%ZFLDTP>)
01200		EXEC	CGFL1
01300		LF	X1,ZIDTYP(XP1)
01400		EXEC	CGPAGC
01500		RETURN
01600		EPROC
     
00100		SUBTTL	=== CGPAGC ===
00200	
00300	COMMENT;
00400	PURPOSE:		GENERATE A LITERAL CONSTANT IF NECESSARY AND COMPILE
00500				A RELOCATABLE INSTRUCTION WITH THE ADDRESS OF THE
00600				CONSTANT IN THE RIGHT HALF, AND THE LEFT HALF AS 
00700				SUPPLIED BY XV1 LEFT HALF.
00800	INPUT ASSERTION:	XP1 POINTS TO A ZCN NODE FOR AN ACTUAL PARAMETER.
00900	;
01000	
01100	CGPAGC:	PROC
01200		IF	CAIE	X1,QTEXT
01300			GOTO	FALSE
01400		THEN
01500			COMPAD	;NOTE THE SPECIAL USE MADE OF COMPAD FOR TEXT CONSTANT
01600	
01700		ELSE
01800			WLF	,ZCNVAL(XP1)
01900			IF
02000				CAIE	X1,QLREAL
02100				GOTO	FALSE
02200			THEN
02300				LD	@
02400				GENDW
02500			ELSE
02600				GENWRD
02700			FI
02800			HLL	XV1
02900			GENREL	;! opcode or left hw,address of constant !;
03000		FI
03100		RETURN
03200		EPROC
     
00100		SUBTTL	=== CGNX ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE THUNK AND FORMAL LOCATION FOR AN ACTUAL
00500				PARAMETER CORRESPONDING TO A FORMAL PARAMETER BY NAME,
00600				WHEN THE ACTUAL PARAMETER HAS A ZNS NODE OR IS
00700				A PROCEDURE, LABEL OR SWITCH.
00800	;
00900	
01000	
01100	CGNX:	PROC
01200		IF	;[7] QUICK procedure
01300			IFOFF	SQUICK
01400			GOTO	FALSE
01500		THEN	;Cannot handle it - error
01600			L	X1,XL2		;[34] Param identification
01700			LF	X2,CALLID	;Id no of procedure
01800			ERRI2	QE,<Q2.ERR+67>	;[34] Too complicated
01900			L	[RTSERROR QDSCON,QSORCER];Prevent execution	;[41]
02000			GENABS
02100			RETURN
02200		FI	;[7]
02300		;ALWAYS GENERATE A THUNK
02400		HRRZ	YPAFIX
02500		OPAC	(JSP	1,)
02600		GENFIX	;! JSP  Xtop+1,past thunk !;
02700		EXEC	CGPA.F
02800		EXEC	CGTHUNK
02900		EXEC	CGPAFX
03000		EXEC	CGPA.F
03100		L	X2,XV1
03200		EXEC	CGFL2
03300		HRRZ	@YTAC
03400		OP	(HRRM	XCB,)
03500		GENABS	;! HRRM XCB,Xtop !;
03600		BRANCH	CGNQ	;Compile ZFLZQU for REF
03700		EPROC
03800	
03900	
04000	COMMENT;
04100	PURPOSE:		LOAD KIND,MODE,TYPE OF XP2 NODE TO XK,XM,XT
04200	;
04300	
04400	CGPA.F:	PROC
04500		LF	XM,ZIDMOD(XP2)
04600		LF	XK,ZIDKND(XP2)
04700		LF	XT,ZIDTYP(XP2)
04800		RETURN
04900		EPROC
     
00100		SUBTTL	=== CGPADT ===
00200	
00300	COMMENT;
00400	PURPOSE:	DETERMINE IF AN ACTUAL PARAMETER EXPRESSION SHOULD YIELD
00500			A DYNAMIC ADDRESS OR AN EXPRESSION VALUE, GIVEN THAT A
00600			THUNK WILL BE COMPILED, I E THE SIMPLEST CASES HAVE BEEN
00700			DEALT WITH ALREADY.
00800	INPUT:		XP1 POINTS TO ACTUAL PARAMETER NODE
00900	OUTPUT:		X1 = (<qdt>B<%ZAPDTP>), WHERE qdt= QDTDYN OR QDTEXP.
01000	;
01100	
01200		IFN <%ZAPDTP-%ZFLDTP>,<CFAIL CGPADT FAILURE>
01300	CGPADT:	PROC
01400		LI	X1,(<QDTDYN>B<%ZFLDTP>)	;DYNAMIC ADDRESS IF
01500		LF	,ZNSKND(XP1)
01600		CAIN	QARRAY
01700		GOTO	L1	; VALUE FOR ARRAYS
01800		CAIE	QSIMPLE			;KIND IS NOT SIMPLE
01900		RETURN
02000		LF	,ZNSTYP(XP1)
02100		CAIN	QLABEL			;OR TYPE IS LABEL
02200		RETURN
02300		LF	,ZNSGEN(XP1)
02400		CAIE	%RP
02500		CAIN	%DOT
02600		RETURN
02700	L1():	LI	X1,(<QDTEXP>B<%ZFLDTP>)	;OTHERWISE EXPRESSION
02800		RETURN
02900		EPROC
     
00100		SUBTTL	=== CGTHUNK ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE THUNK FOR AN ACTUAL PARAMETER POINTED TO BY XP1.
00500	INPUT ASSERTION:	XP1 POINTS TO THE ACTUAL PARAMETER NODE.
00600	OUTPUT ASSERTION:	A THUNK HAS BEEN COMPILED. THE DESCRIPTOR TYPE
00700				ZFLDTP OR ZAPDTP IS PLACED IN XV1 IN THE PROPER FIELD.
00800				XV1 IS OTHERWISE ZERO.
00900	GENERATED CODE:		XWD displacement of thunk save area,0 or next ZAP address
01000				<code for thunk>
01100				JRST	@ZTSRAD(XCB)
01200	;
01300	CGTHUNK:PROC
01400		STACK	YACTAB
01500		IFOFF	SNOFML
01600		SOS	YTAC
01700		SUBI	XL1,(Z	1,)
01800		HRLM	XL1,YCGACT
01900		SETZM	YLXIAC
02000		L	YPAFIX
02100		GENFIX	;! XWD displacement of thunk save area,0 or next ZAP address !;
02200		IF
02300			IFON	STHUNK
02400			GOTO	FALSE
02500		THEN	;MUST ALLOCATE THUNK SAVE AREA
02600			SETON	STHUNK	;- BUT ONLY ONCE
02700			LI	X3,ZTS%S	;[7] Reserve space in display
02800			L	X1,YZHBXCB	;of XCB
02900			LOOP
03000				EXEC	CGUSTD
03100			AS	SOJG	X3,TRUE
03200			SA
03300		FI
03400		EXEC	CGPADT
03500		IF	CAIE	X1,(<QDTEXP>B<%ZFLDTP>)
03600			GOTO	FALSE
03700		THEN
03800			COMPVAL
03900			MOVSI	XV1,(<QDTEXP>B<%ZFLDTP>)
04000		ELSE
04100			COMPCA
04200			MOVSI	XV1,(<QDTDYN>B<%ZFLDTP>)
04300		FI
04400		LF	X1,ZNSKND(XP1)
04500		LF	X2,ZNSMOD(XP1)
04600		LF	X3,ZNSTYP(XP1)
04700	
04800		HRRZ	X4,YCGPAF
04900		EXEC	CGPA.T	;POSSIBLE RESTORE OF XSAC
05000		IF
05100			CAIN	X1,QPROCEDURE
05200			CAIN	X3,QLABEL
05300			GOTO	FALSE
05400		THEN
05500			IF	CAIE	X2,QDECLARED
05600				GOTO	TRUE
05700				IF	WHEN	XP1,ZID
05800					GOTO	FALSE
05900				THEN; REMOTE PROCEDURE
06000					LF	X1,ZNSZNO(XP1)
06100					STEP	X1,ZID
06200				ELSE; DECLARED PROCEDURE
06300					L	X1,XP1
06400				FI
06500				LF	X1,ZIDZQU(X1)
06600				LF	X1,ZQUZB(X1)
06700				LF	X1,ZHBNRP(X1)
06800				JUMPN	X1,FALSE
06900			THEN	;SPECIAL THUNK FOR PROCEDURE WITHOUT PARAMETERS
07000				LI	<OFFSET(ZTSRAD)>(X4)
07100				OP	(JSP	@(XCB))
07200				GENABS
07300				GPUSHJ	(CSSW)	;GET PROCEDURE VALUE ON RETURN
07400				SETZ		;DUMMY ACS MAP
07500				GENABS
07600				EXEC	CGPA.U	;UNCONDITIONAL XSAC RESTORE
07700		FI	FI
07800		LI	<OFFSET(ZTSRAD)>(X4)
07900		OP	(JSP	@(XCB))
08000		GENABS
08100		UNSTK	YACTAB
08200		ADDI	XL1,(Z	1,)
08300		HRLM	XL1,YCGACT
08400		IFOFF	SNOFML
08500		AOS	YTAC
08600		RETURN
08700		EPROC
     
00100		SUBTTL	=== CGFL ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPILE 1ST HALFWORD OF A ZFL TO Xtop.
00500	INPUT ASSERTION:	X2 HAS ZFLDTP SET, OTHERWISE ZERO. XP1 POINTS TO ACTUAL
00600				PARAMETER NODE. XT=TYPE OF FORMAL PARAMETER.
00700	;
00800	
00900	CGFL:	PROC	;GENERATE 1ST HALFWORD OF ZFL IN X2 (ZFLDTP ALREADY SET)
01000	CGFL1:	SETONA	ZFLNTH(X2)	;NO THUNK WHEN ENTERING HERE
01100	CGFL2:	LF	X1,ZIDTYP(XP1)
01200		SF	X1,ZFLATP(,X2)
01300		SF	XT,ZFLFTP(,X2)
01400		IF	;Types are unequal
01500			CAIN	X1,(XT)
01600			GOTO	FALSE
01700		THEN	;[7] Error if QUICK procedure
01800			IF	IFOFF	SQUICK
01900				GOTO	FALSE
02000			THEN	L	X1,XL2	;[34] Identification of parameter
02100				STACK	X2
02200				LF	X2,CALLID	;Id no of procedure
02300				ERRI2	QE,<Q2.ERR+70>	;[34]
02400				UNSTK	X2
02500				L	[RTSERROR QDSCON,QSORCER]	;[41]
02600				GENABS
02700			FI
02800			SETONA	ZFLCNV(X2)
02900		FI
03000		LF	X1,ZIDKND(XP1)
03100		SF	X1,ZFLAKD(,X2)
03200		HLR	X2
03300		OP	(MOVSI)
03400		ADD	YCGACT
03500		GENABS	;! MOVSI Xtop, ZFL codes!;
03600		RETURN
03700		EPROC
03800	
03900	COMMENT;
04000	PURPOSE:		DEFINE, CLEAR AND REALLOCATE YPAFIX
04100	;
04200	
04300	CGPAFX:	PROC
04400		HRRZ	X1,YPAFIX
04500		DEFIX
04600		HRRZ	X1,YPAFIX
04700		CLFIX
04800		ALFIX
04900		HRRM	YPAFIX
05000		RETURN
05100		EPROC
05200	
05300	COMMENT;
05400	PURPOSE:		MAKE XSAC POINT TO THUNK SAVE AREA
05500	;
05600	
05700	CGPA.T:	PROC
05800		;; CONDITIONAL GENERATION OF INSTRUCTION TO RESTORE XSAC -
05900		;; CONDITION NOT YET DETERMINED
06000	CGPA.U:	SAVE	<X1>
06100		LI	(X4)
06200		OP	(MOVEI	XSAC,(XCB))
06300		GENABS
06400		RETURN
06500		EPROC
     
00100		SUBTTL	=== CGZAP ===
00200	
00300	COMMENT;
00400	PURPOSE:		COMPUTE ZAP INSTANCE (ACTUAL PARAMETER DESCRIPTOR)
00500				FOR THE NODE POINTED TO BY XP1. EACH DESCRIPTOR
00600				IS FOLLOWED BY A LINK WORD,WHOSE LEFT HALF IS THE OFFSET
00700				OF THE LOCATION IN DISPLAY(XCB) WHERE THE OBJECT ADDRESS
00800				IS SAVED DURING PARAMETER EVALUATION.
00900	
01000	;
01100	
01200	CGZAP:	PROC
01300		SETZ	XV1,
01400		L	XP2,XP1
01500		EXEC	CGPA.F	;LOAD KIND, MODE, TYPE (XK, XM, XT)
01600		SF	XK,ZPDKND(,XV1)
01700		SF	XT,ZTDTYP(,XV1)
01800		IF	;TYPE REFERENCE, MUST HAVE QUALIFICATION
01900			CAIE	XT,QREF
02000			GOTO	FALSE
02100		THEN
02200			LF	X1,ZNSZQU(XP1)
02300			LF	,ZQUIND(X1)
02400			GENFIX		;! XWD 0,qualif. prototype !;
02500		FI
02600		EXEC	CGPAFX	;Define previous fixup, if any
02700		LF	X1,ZNOTYP(XP1)
02800		SETONA	ZAPNTH(XV1)	;ASSUME NO THUNK
02900		IF	;ZNO OR ZCN NODE
03000			CAIN	X1,QZNS
03100			GOTO	FALSE
03200		THEN
03300			IF	;CONSTANT
03400				CAIE	X1,QZCN
03500				GOTO	FALSE
03600			THEN
03700				TLO	XV1,(<QDTCON>B<%ZAPDTP>)
03800				L	X1,XT
03900				EXEC	CGPAGC
04000			ELSE	;MUST BE ZID
04100				ASSERT <WHENNOT XP1,ZID
04200					RFAIL	CGZAP MEMOP NOT ZID>
04300				IF	;[64] Array, name param, or simple but not label
04400					CAIE	XK,QARRAY	;[64]
04500					CAIN	XM,QNAME
04600					GOTO	TRUE
04700					CAIN	XT,QLABEL
04800					GOTO	FALSE
04900					CAIE	XK,QSIMPLE
05000					GOTO	FALSE
05100				THEN	;Make a NOTHUNK descriptor
05200					LI	X1,(<QDTVSI>B<%ZAPDTP>)
05300					CAIN	XM,QNAME
05400					LI	X1,(<QDTFNM>B<%ZAPDTP>)
05500					TLO	XV1,(X1)
05600					LF	X1,ZIDZQU(XP1)
05700					LF	X2,ZQUZHE(X1)
05800					LF	,ZHEDLV(X2)
05900					MOVN	;EBL CAN NOT BE USED FOR INSPECTED QUANT
06000					SF	,ZAPEBL(,XV1)
06100					LF	,ZQUIND(X1)
06200					HLL	XV1
06300					GENABS
06400				ELSE
06500					LI	X1,(<QDTDYN>B<%ZAPDTP>)
06600					GOTO	L2
06700				FI
06800			FI
06900			L	YPAFIX
07000			GENFIX		;CHAIN TO NEXT ZAP
07100		ELSE	;EXPRESSION
07200	;[73] (Useless)	LF	XP2,ZNSZNO(XP1)
07300			EXEC	CGPA.F
07400			EXEC	CGPADT
07500		L2():!	TLO	XV1,(X1)
07600			SETOFA	ZAPNTH(XV1)	;INDICATE PRESENCE OF THUNK
07700			HRR	XV1,YRELCD	;THUNK ADDRESS
07800			ADDI	XV1,1
07900			L	XV1
08000			GENRLD		;ZAP
08100			EXEC	CGTHUNK
08200		FI
08300		IF	;LAST PARAMETER
08400			IFOFF	ZNOLST(XP1)
08500			GOTO	FALSE
08600		THEN
08700			EXEC	CGPAFX
08800			SETZ
08900			GENABS	;END OF CHAIN
09000		FI
09100		RETURN
09200		EPROC
09300	
09400		LIT
09500		RELOC
09600		VAR
09700		END