Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/rts/phpt.mac
There are 2 other files named phpt.mac in the archive. Click here to see a list.
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>,<DEFINE NOTHUNK(A)<JUMPGE A,FALSE>>
IFN <%ZFLNTH>,<DEFINE NOTHUNK(A)<IFOFFA ZFLNTH(A)
GOTO FALSE>>
DEFINE ABSADDR(A,B) <HLRZ A,B
ADDI 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>+<QREF>B<%ZTDTYP>+<QDTCON>B<%ZAPDTP>+<QSIMPLE>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