perm filename PHPT.MAC[SIM,SYS] blob sn#460171 filedate 1979-07-20 generic text, type T, neo UTF8
	SUBTTL	PARAMETER TRANSFER TO FORMAL OR VIRTUAL PROCEDURE

; AUTHOR:	LARS ENDERIN
; VERSION:	1
; PURPOSE:	HANDLES PARAMETER TRANSMISSION TO FORMAL AND
;		VIRTUAL PROCEDURES.

; CONTENTS:

		ENTRY	.PHPT

	SEARCH	SIMMAC,SIMRPA,SIMMCR

	RTITLE	PHPT
	SALL
	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
	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)
		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
		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
			LF	XT,ZAPDTP
			CAIN	XT,QDTCON
			PHERR	10,Text constant by reference is illegal
		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
		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)
		;[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)
	IFON	ZPCNCK(XT)	;Always ok if NOCHECK
	BRANCH	(XRET)
	LF	,ZAPZQU(XAP)
	LF	XT,ZFRZPR(XFP)
	CAIN	(XT)
	BRANCH	(XRET)
	JUMPE	(XRET)
	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
	WSF	XRET,ZTSRAD(XSAC)
	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
	MOVSM	XCB,OFFSET(ZTSZBI)(XSAC); ZTSZBI,,ZTSZAC
	HRRZ	XCB,XFL0		; XCB :- thunk block
	WSF	XRET,ZTSRAD(XSAC)	; SAVE THE 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
	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)

	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]

	Q==X16-XWAC1	;SAVE FROM XWAC2 UPWARDS

PHPTSR:	STACK	X0
	STACK	XSAC
	STACK	XTAC
	LI	XSAC,1(XPDP)
	ADD	XPDP,[Q,,Q]
	HRLI	XSAC,XWAC2
	BLT	XSAC,(XPDP)
	BRANCH	(XRET)

;------------------------------------------------------------------------------;

;CALL:	GETREGS		[JSP	XRET,PHPTGR]

PHPTGR:	SUB	XPDP,[Q,,Q]
	ST	XRET,XRET-XWAC1(XPDP)
	LI	XSAC,XWAC2
	HRLI	XSAC,1(XPDP)
	BLT	XSAC,X16
	UNSTK	XTAC
	UNSTK	XSAC
	UNSTK	X0
	BRANCH	(XRET)
	SUBTTL	END OF PHPT

	LIT
	END