SUBTTL PARAMETER TRANSFER TO FORMAL, NOCHECK, VIRTUAL PROCEDURE ; AUTHOR: LARS ENDERIN ; VERSION: [30,34,74,117,161,240,264] ; PURPOSE: HANDLES PARAMETER TRANSMISSION TO FORMAL ; VIRTUAL, AND NOCHECK PROCEDURES. ; CONTENTS: ENTRY .PHPT SEARCH SIMMAC,SIMRPA,SIMMCR SALL RTITLE PHPT MACINIT ERRMAC PH ;-- LOCAL DEFINITIONS IFE <%ZFLNTH>,> IFN <%ZFLNTH>,> DEFINE ABSADDR(A,B) SUBTTL .PHPT, REGISTER ASSIGNMENTS, MACROS AND OPDEF'S ;REGISTER ASSIGNMENTS; ;--------------------; XIB= X14 ;Address of invoking block = XCB on entry XAT= X13 ;Actual parameter type XAK= X12 ;Actual parameter kind XFT= X11 ;Formal parameter type XFK= X10 ;Formal parameter kind XAP= XTAC ;Actual parameter list position XFP= XIAC ;Formal parameter list pointer XRET= X7 ;JSP return register XFAD= X6 ;Formal location address XT= X5 ;Temporary register XFL0= X0 ;First word of ZFL or ZAP XFL1= XAP ;Second word of ZFL XRHT= XFT ;Right hand side type (.PHCV parameter) XLHT= XAT ;Left hand side type (.PHCV parameter) ; COMPUTE VALUE OF ACTUAL PARAMETER TO XRAC & XRAC1 DEFINE VALUE < IF NOTHUNK THEN GETVALUE ELSE IF CAIE XAK,QSIMPLE GOTO FALSE THEN THUNKENTER THUNKXIT LOADVALUE ELSE THUNKENTER PROCVALUE THUNKXIT FI FI > ; COMPUTE DYNAMIC ADDRESS OF ACTUAL PARAMETER TO XRAC DEFINE DYNADDR < IF NOTHUNK THEN DADDR ELSE THUNKENTER THUNKXIT FI > OPDEF PROCVALUE [JSP XRET,PHPV] OPDEF THUNKENTER [JSP XRET,PHPTET] OPDEF THUNKXIT [JSP XRET,PHPTXT] OPDEF GETVALUE [PUSHJ XPDP,PHPTGV] OPDEF LOADVALUE [JSP XRET,PHPTLV] OPDEF DADDR [PUSHJ XPDP,PHPTDA] OPDEF STORE [GOTO PHPTS1] OPDEF STOREDOUBLE [GOTO PHPTS2] OPDEF STOREVALUE [GOTO PHPTSV] OPDEF CHECK [JSP XRET,] OPDEF SAVEREGS [JSP XRET,PHPTSR] OPDEF GETREGS [JSP XRET,PHPTGR] SUBTTL .PHPT Comment / Purpose: To check and transmit parameters to a formal or virtual procedure. Input: The calling sequence to .PHPT is rather special: compute dynamic address of formal or virtual procedure to top ac's PUSHJ XPDP,.CSSW ;set up new procedure block XWD number of intermediate results,address of map Z n ;number of actual parameters PUSHJ XPDP,.PHPT [Z prototype address] ;Only for REF ZAP1: actual parameter descriptor (ZAP) for first param. XWD a,ZAP2 [thunk for first parameter, if any thunk is needed] [Z prototype address] ;Only for REF ZAP2: ZAP for second parameter XWD a,ZAP3 [thunk for second parameter] ... [Z prototype address] ;Only for REF ZAPn: ZAP for n'th parameter XWD a,ZAPEND [thunk for n'th parameter] ZAPEND: XWD 0,0 PUSHJ XPDP,.CSEN ;enter procedure body In the above sequence, "a" is the offset of the last word of the thunk save area in the display vector. Function: Treat the parameters in sequence. Each parameter is first checked for compatibility. If ZAPNTH is set, the ZAP specifies the address or value of the quantity directly (generally, by effective block level and offset). The quantity can be loaded, possibly converted or qualification checked, and stored in the formal location . If the formal parameter is specified NAME, a ZFL instance is computed and stored. If a thunk has been compiled, and the formal parameter is not of name mode, the thunk must be evaluated to yield the value. This is done in the same way as in .PHFA or .PHFV, with the additional requirement that the current positions in the actual (ZAP) and formal (ZFP) descriptor lists must be remembered. This is done by storing the addresses of the ZAP and the ZFP descriptors in the formal location until the value has been computed. Since the dynamic address of the formal location is saved in the thunk save area, the formal and actual descriptor positions can be recovered on return from the thunk. The dummy ZAP of all zeros finishes the parameter list. / SUBTTL .PHPT, MAIN LOOP .PHPT: PROC LOWADR(XT) CFORBID L XIB,XCB L XCB,XRAC HRRZ XAP,(XPDP) ;XAP keeps track of position in ZAP list LF XSAC,ZBIZPR(XRAC) ;Procedure prototype edit(100) LF XFP,ZPCNRP(XSAC) ;[100] Number of formal parameters L OFFSET(ZPCNCK)(XSAC) ;[100] IF ;[100] Incorrect number of parameters CAMN XFP,-2(XAP) GOTO FALSE IFOFFA ZPCNCK ;AND NOT NOCHECK GOTO TRUE CAML XFP,-2(XAP) ;OR more actual parameters than formal GOTO FALSE THEN ;Error PHERR 6,Wrong number of parameters ... FI ;[100] LI XFP,ZPC%S(XSAC) ;Find first ZFP WHILE ;More parameters to go L (XAP) edit(74) JUMPN TRUE ;[74] HLRZ 1(XAP) ;[74] End of list unless actual is constant NONE Q==(1B<%ZAPNTH>+B<%ZTDTYP>+B<%ZAPDTP>+B<%ZPDKND>) CAIE Q ;[74] GOTO FALSE ;[74] DO IF ;There is a prototype address in the first word TLNE -1 GOTO FALSE THEN ;Skip to next word ADDI XAP,1 L (XAP) FI EXEC PHPTNM ;Check if actual is a name parameter passed on - ; use ZFL in that case. EXEC PHPTAF ;Get actual & formal type & kind, formal mode ;Also get address of formal location and of calling block. ;Different kinds ? CAIE XAK,(XFK) CHECK KINDS CHECK COMPATIBLE LF XT,ZFPMOD(XFP) CAIN XT,QVALUE BRANCH PHVALUE CAIN XT,QREFERENCE BRANCH PHREFERENCE CAIN XT,QNAME BRANCH PHNAME RFAIL IMPOSSIBLE FORMAL MODE PHPTS2: ST XRAC1,1(XFAD) ;End up here if two-word value PHPTS1: ST XRAC,(XFAD) ;End up here if one-word value ADDI XFP,1 LF XT,ZBIZPR(XCB) IF IFON ZPCNCK(XT) GOTO FALSE THEN CAIN XFT,QREF ADDI XFP,1 FI HRRZ XAP,1(XAP) OD TRIMSTACK L XRAC,XCB LOWADR(XT) CALLOW BRANCH 1(XAP) EPROC SUBTTL .PHPT, VALUE mode PHVALUE: IF ;Actual has kind SIMPLE CAIE XAK,QSIMPLE GOTO FALSE THEN PHPT.1:! CAILE XAT,QTEXT ;Must be value type or text PHERR 7,Wrong actual parameter type VALUE IF CAIE XAT,QTEXT GOTO FALSE THEN ;Copy the text SAVEREGS EXEC TXCY Z ;No acs GETREGS ZF ZTVCP(,XRAC) FI IF ;Different arithmetic types CAIG XFT,QLREAL CAIN XFT,(XAT) GOTO FALSE THEN ;Convert actual to formal type STACK XFT EXCH XFT,XAT EXEC PHCV UNSTK XFT ELSE ;Types must be identical CAIE XAT,(XFT) PHERR 7,Wrong actual type FI STOREVALUE ELSE IF ;ARRAY actual parameter CAIE XAK,QARRAY GOTO FALSE THEN CHECK SAMETYPE edit(117) IF NOTHUNK ;[117] THEN GETVALUE ELSE THUNKENTER THUNKXIT FI ;[117] SAVEREGS EXEC CSCA ;Copy the array GETREGS STORE ELSE IF ;PROCEDURE CAIE XAK,QPROCEDURE GOTO FALSE THEN CAIN XFK,QSIMPLE GOTO PHPT.1 ;Special case again RFAIL PROC BY VALUE PHPT ELSE ;IMPOSSIBLE RFAIL PHPT IMPOSSIBLE PARAMETER KIND FI FI FI SUBTTL .PHPT, reference mode PHREFERENCE: IF ;SIMPLE CAIE XAK,QSIMPLE GOTO FALSE THEN ;Must be TEXT, REF or LABEL PHPT.2:! IF ;TEXT CAIE XAT,QTEXT GOTO FALSE THEN ;Must not be constant (except NOTEXT) LF XT,ZAPDTP edit(264) IF ;[264] Constant, but not NOTEXT CAIE XT,QDTCON GOTO FALSE SKIPE @ THEN PHERR 10,Text constant by reference is illegal FI FI VALUE IF ;REF CAIE XAT,QREF GOTO FALSE THEN ;Check qualification STACK XWAC1 SETO ;NONE or subclass valid LF XSAC,ZFRZPR(XFP) EXEC CSQU IF JUMPN XWAC1,FALSE THEN PHERR 11,Wrong qualification on actual parameter FI UNSTK XWAC1 FI STOREVALUE ELSE IF ;ARRAY CAIE XAK,QARRAY GOTO FALSE THEN CHECK SAMETYPE edit(117) IF NOTHUNK ;[117] THEN GETVALUE ELSE THUNKENTER THUNKXIT FI ;[117] STORE ELSE IF CAIE XAK,QPROCEDURE GOTO FALSE THEN CAIN XFK,QSIMPLE GOTO PHPT.2 ;Exceptional case again CHECK SAMETYPE DYNADDR STOREDOUBLE ELSE ;IMPOSSIBLE RFAIL IMPOSSIBLE PARAM KINDS FI FI FI SUBTTL .PHPT, NAME mode PHNAME: IF ;Actual parameter is itself a name parameter JUMPE XRAC1,FALSE THEN ;Copy the ZFL with possibly changed type LD XRAC,(XRAC1) SF XFT,ZFLCTP(,XRAC) ;Note !CNV bit cleared ELSE ;Construct ZFL record from ZAP HLLZ XRAC,(XAP) ;NTH, ATP, DTP, AKD SF XFT,ZFLCTP(,XRAC) ;CNV+FTP IF NOTHUNK(XRAC) THEN ;An identifier needs a block instance LF XT,ZAPEBL(XAP) IF ;EBL was given JUMPE XT,FALSE THEN ;Find block instance from display of caller MOVN XT,XT ADDI XT,(XIB) HRR XRAC,(XT) FI ELSE ;XIB is block of thunk HRRI XRAC,(XIB) FI LF XRAC1,ZAPADR(XAP) IF CAIE XAT,QREF GOTO FALSE THEN ;Get qualification LF ,ZAPZQU(XAP) SF ,ZFLZQU(,XRAC) FI FI IF ;Different arithmetic actual/formal types CAIE XAT,(XFT) CAIN XFT,QNOTYPE GOTO FALSE THEN SETONA ZFLCNV(XRAC) edit(34) ;[34] Fix until compiler can handle this properly CAIE XAK,QPROCEDURE ;[34] Procedure CAIN XAK,QARRAY ;[34] and array PHERR 7,Wrong actual parameter type ;[34] FI STOREDOUBLE SUBTTL STOREVALUE PHPTSV: ;Store value CAIE XFK,QSIMPLE ;If not simple, dynamic address GOTO PHPTSD CAIE XFT,QLREAL CAIN XFT,QTEXT GOTO PHPTS2 CAIE XFT,QLABEL GOTO PHPTS1 GOTO PHPTS2 PHPTSD: ;Store dynamic address IF CAIE XFK,QPROCEDURE GOTO FALSE THEN CAIN XAT,QLABEL GOTO PHPTS1 GOTO PHPTS2 FI CAIE XFT,QLABEL CAIN XFT,QREF GOTO PHPTS2 GOTO PHPTS1 SUBTTL CHECK SAMETYPE: CAIN XFT,QNOTYPE BRANCH (XRET) ;Notype formal procedure matches any procedure CAIE XAT,(XFT) PHERR 7,Wrong actual parameter type CAIE XAT,QREF BRANCH (XRET) LF XT,ZBIZPR(XCB) edit(161) L XT,OFFSET(ZPCNCK)(XT) ;[161] IFONA ZPCNCK(XT) ;[161] Always ok if NOCHECK BRANCH (XRET) LF XT,ZAPZQU(XAP) ;[161] JUMPE XT,(XRET) ;[161] Ok if no qualif RIGHTHALF(ZFRZPR) ;[161] XOR XT,OFFSET(ZFRZPR)(XFP) ;[161] TRNE XT,-1 ;[161] PHERR 11,Wrong qualification on actual parameter BRANCH (XRET) COMPATIBLE: CAIE XFT,QNOTYPE CAIN XAT,(XFT) BRANCH (XRET) CAIG XAT,QLREAL CAILE XFT,QLREAL PHERR 12,Actual & formal types incompatible BRANCH (XRET) KINDS: IF ;Parameterless procedure may match simple CAIN XFK,QSIMPLE CAIE XAK,QPROCEDURE GOTO TRUE CAIL XFK,QLABEL ;Not label or notype proc GOTO TRUE CAIN XAT,(XFT) ;If same type, may be ok GOTO FALSE CAILE XAT,QLREAL ;Otherwise both must be arithmetic GOTO TRUE CAIG XFT,QLREAL GOTO FALSE THEN ;It was not right, after all PHERR 13,Wrong kind of actual parameter FI BRANCH (XRET) SUBTTL ACTUAL, FORMAL TYPES, KINDS, ETC PHPTAF: LF XAT,ZTDTYP(XAP) LF XAK,ZPDKND(XAP) LF XFT,ZTDTYP(XFP) LF XFK,ZPDKND(XFP) LF XT,ZBIZPR(XCB) IF ;NOCHECK assembly procedure L XT,OFFSET(ZPCNCK)(XT) IFOFFA ZPCNCK(XT) GOTO FALSE THEN ;Assume formal type & kind same as actual type & kind L XFT,XAT L XFK,XAK FI ;Get address of calling block LF XIB,ZDRZBI(XCB) ;Get absolute address of formal location LF XFAD,ZFPOFS(XFP) ADDI XFAD,(XCB) RETURN PHPTNM: ;Check if actual parameter is itself a name parameter, and ;set XRAC1 = address of ZFL, XFL0 = first word of ZFL in that case. ;Otherwise, set XRAC1=0. SETZ XRAC1, LF XRAC,ZAPDTP(XFL0) IF CAIE XRAC,QDTFNM GOTO FALSE THEN LF XT,ZAPEBL(XFL0) MOVN XRAC1,XT ADDI XRAC1,(XIB) L XRAC1,(XRAC1) ADD XRAC1,XFL0 L XFL0,(XRAC1) FI RETURN SUBTTL PROCVALUE ;CALL: PROCVALUE [JSP XRET,PHPV] PHPV: ; --- ACTUAL WAS A PROCEDURE - SHOULD HAVE NO PARAMETER STACK X0 ;Returned here from thunk by JSP ... LF XT,ZDPZPR(XRAC) SKIPGE OFFSET(ZPCPAR)(XT) PHERR 1,Expression expected as actual parameter ; NO PARAMETER, SO GO AND GET THE VALUE edit(240) HRRZM XRET,OFFSET(ZTSRAD)(XSAC) ;[240] Save return address RETURN SUBTTL THUNKENTER, THUNKXIT ;CALL: THUNKENTER [JSP XRET,PHPTET] PHPTET: PROC ;ENTER THUNK FROM PHPT ;Save parameter list positions in formal location HRLM XAP,(XFAD) HRRM XFP,(XFAD) IF ;Actual parameter was a formal parameter JUMPE XRAC1,FALSE THEN ;Use ZFL instead of ZAP LI XRAC,(XCB) SUBI XFAD,(XCB) HRL XRAC,XFAD L XFL1,1(XRAC1) LFE XSAC,ZTHZTS(XFL1); DISPLACEMENT + BLOCK INSTANCE ADDRESS ELSE L XRAC,XFAD SUBI XRAC,(XCB) SF XRAC,ZDVOFS(,XRAC) SF XCB,ZDVZBI(,XRAC) LFE XSAC,ZTHZTS(XAP,1) LF XFL0,ZDRZBI(XCB) LF XFL1,ZAPADR(XAP) FI ADD XSAC,XFL0 WSF XRAC,ZTSFAD(XSAC) ; SAVE FORMAL ADDRESS (IN DYNAMIC FORM) LOWADR CFORBID UNSTK OFFSET(ZTSRSR)(XSAC) ; OBJECT CODE RETURN ADDRESS edit(240) HRRZS OFFSET(ZTSRSR)(XSAC) ;[240] Clear left half to avoid confusion MOVSM XCB,OFFSET(ZTSZBI)(XSAC); ZTSZBI,,ZTSZAC HRRZ XCB,XFL0 ; XCB :- thunk block HRRZM XRET,OFFSET(ZTSRAD)(XSAC) ;[240] Save return address CALLOW BRANCH 1(XFL1) ; ENTER THUNK EPROC ;------------------------------------------------------------------------------; ;CALL: THUNKXIT [JSP XRET,PHPTXT] PHPTXT: LOWADR(XT) CFORBID LF XT,ZTSFAD(XSAC) ABSADDR XFAD,XT HLRZ XAP,(XFAD) ;Recover parameter list pointers HRRZ XFP,(XFAD) STACK OFFSET(ZTSRSR)(XSAC) ;Restore obj code return LF XCB,ZTSZBI(XSAC) ;Restore XCB edit(27) SETZM OFFSET(ZTSZBI)(XSAC) ;[27] Zero dynamic ref in thunk save SETZM OFFSET(ZTSFAD)(XSAC) ; area to avoid confusion in SAGC LOWADR(XT) CALLOW EXEC PHPTAF ;Recompute XAT, XAK, XFT, XFK, XIB, XFAD BRANCH (XRET) SUBTTL DADDR ;CALL: DADDR [PUSHJ XPDP,PHPTDA] PHPTDA: IF ;Actual is name parameter JUMPE XRAC1,FALSE THEN ;Dynamic and absolute address from ZFL LF XRAC,ZFLZBI(XRAC1) HRL XRAC,1(XRAC1) ABSADDR XRAC1,XRAC ELSE ;Get dynamic and absolute address from ZAP LF XRAC,ZAPOFS(XAP) LF XRAC1,ZAPEBL(XAP) IF JUMPE XRAC1,FALSE THEN MOVN XRAC1,XRAC1 ADDI XRAC1,(XIB) L XRAC1,(XRAC1) EXCH XRAC,XRAC1 HRL XRAC,XRAC1 FI ADDI XRAC1,(XRAC) FI RETURN SUBTTL GETVALUE, LOADVALUE ;CALL: GETVALUE [PUSHJ XPDP,PHPTGV] PHPTGV: DADDR LF XT,ZAPDTP(XFL0) CAIE XT,QDTICO ;Value in XRAC already if short constant LD XRAC,(XRAC1) ;Otherwise load value RETURN ;------------------------------------------------------------------------------; ;CALL: LOADVALUE [JSP XRET,PHPTLV] PHPTLV: L XFL0,(XAP) LF XT,ZAPDTP(XFL0) IF ;Name parameter as actual parameter CAIE XT,QDTFNM GOTO FALSE THEN ;Get ZFL instead of ZAP LF XT,ZAPEBL(XFL0) MOVN XT,XT ADDI XT,(XIB) L XT,(XT) ADD XT,XFL0 L XFL0,(XT) FI IFONA ZFLVTD(XFL0) BRANCH (XRET) edit(30) CAIE XAT,QLABEL ;[30] CAIN XAK,QPROCEDURE ;[30] BRANCH (XRET) ;[30] ABSADDR XT,XRAC LD XRAC,(XT) BRANCH (XRET) SUBTTL SAVEREGS,GETREGS ;CALL: SAVEREGS [JSP XRET,PHPTSR] edit(145) PHPTSR: ;[145] STACK XFP STACK XAP BRANCH (XRET) ;------------------------------------------------------------------------------; ;CALL: GETREGS [JSP XRET,PHPTGR] PHPTGR: ;[145] UNSTK XAP UNSTK XFP EXEC PHPTAF ;Recompute addresses etc BRANCH (XRET) SUBTTL END OF PHPT LIT END