Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/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