SUBTTL	CLASS and PREFIXED BLOCK handling

	SEARCH	SIMMAC,SIMMCR,SIMRPA
	SALL
	MACINIT
	ERRMAC(CP)
	RTITLE(CP)
	TWOSEG
	RELOC	400k

; Author:	Lars Enderin, Claes Wihlborg  Dec 1973
; Version:	4
; Purpose:	The CP module is concerned with Classes and Prefixed blocks.
;		It handles transfer of control between the various
;		access levels, block creation, and quasi-parallel sequencing.

;		The following procedures are part of the CP module:

entry	.CPCA	; CALL routine (reverse of detach)
entry	.CPCD	; End declarations in a class body
entry	.CPCI	; Execute INNER body of a class instance
entry	.CPDT	; DETACH routine.
entry	.CPE0	; End of class body at prefix level 0.
entry	.CPNE	; Creates a new class instance for an <object generator>.
entry	.CPPD	; End declarations in a prefixed block
entry	.CPRS	; RESUME routine.
entry	.CPSP	; Create an instance of a prefixed block

EXTERN	.CSRA,.CSEN,.SADB,.SAIN


; Provide efficient test for detached state, if possible

IFE <%ZDNDET>,<DEFINE DETACHED(X)<
		JUMPE	X,FALSE>
		DEFINE NOTDETACHED(X)<
		JUMPL	X,FALSE>
>
IFN <%ZDNDET>,<CFAIL FATAL ERROR ZDNDET not in bit 0	;;[77]
>
	SUBTTL	.CPCA, CALL routine.
Comment;

Purpose:	To implement the system procedure CALL.
Input:		XZBI (=XWAC1) contains pointer to called class instance.
Function:	The input object must not be attached, terminated or operating.
		Attach the object to the calling block and enter the attached
		block at its reactivation point.
Error exits:	CPERR 4,5,6,7.
;

.CPCA:	PROC
		edit(41)
	IF	;[41] XZBI==NONE
		CAIE	XZBI,NONE
		GOTO	FALSE
	THEN	CPERC	QDSCON,4,CALL: object NONE
		RETURN
	FI	;[41]

;INSPECT XZBI DO

	WLF	,ZDNLNK(XZBI)
	IF	;[41] Terminated
		IFOFFA	ZDNTER
		GOTO	FALSE
	THEN
		CPERC	QDSCON,5,CALL: terminated class instance
		RETURN
	FI	;[41]
	IF	;[41]
				edit(77)
		NOTDETACHED	;[77]
	THEN	CPERC	QDSCON,6,CALL: attached class instance
		RETURN
	FI	;[41]
	SKIPA	XZ,XCB
	LOOP	;Following dyn. links to nearest detached blk instance
		LF	XZ,ZDRZBI(XZ)
	AS
		SKIPL	OFFSET(ZDNDET)(XZ)	;[77]
		GOTO	TRUE
	SA
	CAMN	XZ,XZBI
	CPERR	7,CALL: operating class instance
	LOWADR
	IFG QSADEA,<
	L	YSADEA(XLOW)
	CAIG	(XCB)
	HRRZM	XCB,YSADEA(XLOW)
	>
	CFORBID				;Cannot allow REENTER here
	WLF	XOUT,ZDRZBI(XZBI)	;Copy dynamic link in case called class
	WSF	XOUT,ZDRZBI(XZ)		;contains active prefixed block
	;Check operating chain for conflict
	WHILE		;Static environment exists
		LF	XSAC,ZBIZPR(XZ)
		LFE	XSAC,ZCPSBL(XSAC)
		CAML	XSAC,[-QZDRZPB]
		GOTO	FALSE
	DO		;Check for conflict
		ADD	XZ,XSAC
		SKIPA	XZ,(XZ)
		LOOP
			LF	XZ,ZDRZBI(XZ)
		AS
			SKIPL	OFFSET(ZDNDET)(XZ)	;[77]
			GOTO	TRUE	;When attached
		SA
		CAMN	XZ,XZBI
		CPERR	7,CALL: operating class instance
	OD
	HRL	XCB,(XPDP)
	MOVSM	XCB,OFFSET(ZDRZBI)(XZBI)	;ATTACH CALLED CLASS TO CALLER
	SETOFF	ZDNDET(XZBI)
	WHILE	;Reactivation point is inside a prefixed block
		TRNE	XOUT,-1
		GOTO	FALSE
	DO	;Descend into inner QPS
		HLR	XZBI,XOUT
		WLF	XOUT,ZDRZBI(XZBI)
	OD
	HLRZ	XCB,XOUT
	TRIMSTACK
	CALLOW
	BRANCH	(XOUT)
	EPROC
	SUBTTL	.CPCD (END CLASS BODY DECLARATIONS)

Comment;

Purpose:	To finish the declaration coding at the present prefix level.

Call:		MOVEI	XSAC,prefix level
		JRST	.CPCD

Function:	If innermost level, go to statements of outermost level.
		Otherwise find next inner level and go to its declarations.
;

.CPCD:	PROC
	LOWADR
	CFORBID
	LF	XZ,ZBIZPR(XCB)	; Prototype of object
	LF	XL,ZCPPRL(XZ)	; Its prefix level
	SUB	XSAC,XL
	IF	;Not at innermost level
		JUMPE	XSAC,FALSE
	THEN	;Find next inner prefix and go to its declaration coding
		IF	AOJE	XSAC,FALSE
		THEN
		LOOP
			LF	XZ,ZCPZCP(XZ)
		AS
			AOJL	XSAC,TRUE
		SA
		FI
		LF	XSAC,ZPCDEC(XZ)
	ELSE	;Find outermost prefix and goto its statements
		WHILE	;TRUE
		DO	;Follow prefix chain
			SKIPN	OFFSET(ZCPZCP)(XZ)
			GOTO	L9
			LF	XZ,ZCPZCP(XZ)
		OD
		ASSERT<RFAIL	Bad prefix chain CPCD>
	L9():!	LF	XSAC,ZCPSTA(XZ)
	FI
	CALLOW
	BRANCH	(XSAC)
	EPROC
	SUBTTL	.CPCI (Call INNER)

Comment;

Purpose:	To transfer control to an INNER class.

Call:		MOVEI	XSAC,prefix level
		JRST	.CPCI

Function:	If innermost level, return via ZCPIEA(XSAC),
		otherwise go to statements of INNER class.
;


.CPCI:	PROC
	LOWADR
	CFORBID
	LF	XZ,ZBIZPR(XCB)		; Prototype of object
	LF	XL,ZCPPRL(XZ) 		; Its prefix level
	SUB	XSAC,XL			; Compute difference
	JUMPE	XSAC,@OFFSET(ZCPIEA)(XZ); Return directly if at innermost level

	;Find next inner level and go to its statements

	IF	;More than one level inside
		AOJE	XSAC,FALSE
	THEN	;Find next inner level
		LOOP	;following the prefix chain
			LF	XZ,ZCPZCP(XZ)	
		AS	;the correct level is not found
			AOJL	XSAC,TRUE
		SA
	FI
	CALLOW
	BRANCH	@OFFSET(ZCPSTA)(XZ)	
	EPROC
	SUBTTL	.CPDT (DETACH)

Comment;

Purpose:	To implement the system procedure DETACH.

Call:		PUSHJ	XPDP,.CPDT

Function:	Direct return if called in a prefixed block. If called
		in an attached class instance, detach that instance with a
		reactivation point after the call on DETACH. Return the
		object reference to the object generator (with intermediate
		results restored).
		If called in already detached instance, set reactivation point
		and resume enclosing quasi-parallel system.
;


	ASSERT	<RIGHTHALF ZDRARE
		RIGHTHALF ZPCDLE
		>
.CPDT:	PROC
	LOWADR
	CFORBID
	WLF	XSAC,ZDNTYP(XCB)
	IF	;PREFIXED BLOCK
		LF	,ZDNTYP(,XSAC)
		CAIE	QZPB
		GOTO	FALSE
	THEN
		CALLOW
		RETURN
	FI
	L	XZBI,XCB	; XZBI :- XCB;
	HRL	XCB,(XPDP)
	IF
		NOTDETACHED(XSAC)
	THEN
		WLF	XOUT,ZDRARE(XCB); XOUT := XCB.ZDR.(ZDRZBI,ZDRARE);
		MOVSM	XCB,OFFSET(ZDRZBI)(XZBI)
		HRRZM	XOUT,(XPDP)	;Prepare for return to object generator
		SETONA	ZDNDET(XSAC)	; XCB.ZDNDET := TRUE;
		WSF	XSAC,ZDNLNK(XCB)
		HLRZ	XCB,XOUT	; XCB :- XZBI.ZDRZBI;
		IF	;an accumulator stack exists
			IFOFFA	ZDNACS(XSAC)
			GOTO	FALSE
		THEN	;-- Retrieve pointer to the accumulator stack --;
			LF	XZ,ZBIZPR(XZBI)	; XCB-display block length
			MOVN	XL,OFFSET(ZPCDLE)(XZ)
			ADDI	XL,(XZBI)	; gives start of ZDR record
			LF	XSAC,ZDRZAC(XL)
			EXEC	.CSRA		;Restore ACS;
		FI
	ELSE	; --- Already detached - Set reactivation point --- ;
		MOVSM	XCB,OFFSET(ZDRZBI)(XZBI);  XZBI.ZDRZBI :- XCB;
		MOVSI	(1B<%ZDNDET>)
		LOOP	;Follow operating chain
			LF	XSAC,ZBIZPR(XZBI)
			LFE	XSAC,ZCPSBL(XSAC)
			ADDI	XSAC,(XZBI)
			L	XZBI,(XSAC)
			WHILE	;block not detached
				TDNE	OFFSET(ZDNDET)(XZBI)
				GOTO	FALSE
			DO	;follow dynamic links
				LF	XZBI,ZDRZBI(XZBI)
			OD
		AS	;to nearest prefixed block
			LF	XSAC,ZDNTYP(XZBI)
			CAIE	XSAC,QZPB
			GOTO	TRUE
		SA
		WHILE	;actual reactivation point is further into q.p. syst.
			WLF	XOUT,ZDRZBI(XZBI)
			TRNE	XOUT,-1
			GOTO	FALSE
		DO	;follow dynamic links inwards
			HLR	XZBI,XOUT
		OD
		;Restart enclosing q.p. system at reactivation point
		HLRZ	XCB,XOUT
		HRRM	XOUT,(XPDP)
	FI
	CALLOW
	RETURN
	EPROC
	SUBTTL	.CPE0, End of class body at prefix level 0.
Comment;

Purpose:	To exit from a class without a prefix or from a subclass,
		none of whose prefix classes has an INNER statement.

Call:		JRST	.CPE0

Function:	If prefixed block, transfer control to statement after
		the prefixed block (given by ZCPIEA of the prototype),
		otherwise terminate and detach the block instance.

Calls:		.CPDT
;

.CPE0:	PROC
	SETON	ZDNTER(XCB)
	EXEC	.CPDT

	;Here if prefixed block

	LOWADR
	CFORBID
	LF	XSAC,ZBIZPR(XCB)
	LFE	XZBI,ZCPSBL(XSAC)
	ADD	XZBI,XCB
	L	XCB,(XZBI)
	CALLOW
	BRANCH	@OFFSET(ZCPIEA)(XSAC)
	EPROC
	SUBTTL	.CPNE, Create a new class instance for an <object generator>.

Comment;

Purpose:	To create a class object with attached display vector.

Call:		PUSHJ	XPDP,.CPNE
		XWD	display offset, prototype address

Output:		XRAC (=XWAC1) contains address of class instance.

Function:	Allocate class instance and display vector. Copy display from
		the block found at the given display offset. If the class has
		parameters, return to parameter evaluation sequence,
		otherwise enter the class coding.

Calls:		.SADB
		.CSEN
;

.CPNE:	PROC
	MOVSI	XSAC,QZCL
	HRR	XSAC,@(XPDP)
	EXEC	.SADB	;Allocate class instance
	IFN QSADEA,<
	L	YSATOP(XLOW)
	ST	YSADEA(XLOW)
	>
	HLRE	XWAC5,@(XPDP)
	IF	;No SBL given
		JUMPL	XWAC5,FALSE
	THEN	;Take SBL from prototype instead
		LFE	XWAC5,ZCPSBL(XSAC)
	FI
	ADDI	XWAC5,(XCB)	;Find block on level SBL
	L	XWAC5,(XWAC5)
	LFE	XWAC3,ZPREBL(XSAC)
	ADDI	XWAC3,QZDRZPB
	LI	XWAC4,(XRAC)

	LOOP	;Copy display except for innermost level
	AS
		AOJG	XWAC3,FALSE
		LF	,ZDRZPB(XWAC5)
		SF	,ZDRZPB(XWAC4)
		SUBI	XWAC4,1
		SOJA	XWAC5,TRUE
	SA
	IF	;Display must be kept on termination
		IFOFF	ZCPKDP(XSAC)
		GOTO	FALSE
	THEN
		SETON	ZDNKDP(XRAC)
	FI
	AOS	(XPDP)
	BRANCH	CPIN	;Special initialisation of any prefix
	EPROC
	SUBTTL	CPIN

Comment;

Purpose:	To initialise REF and/or ARRAY variables in any prefix part
		and return to caller of .CPNE or .CPSP (via .CSEN if parameters
		exist)

Input:		XSAC = prototype address of class or prefixed block

Function:	Follow ZCPZCP chain and call .SAIN for each prefix.
		Return.
;
CPIN:	L	XTAC,XSAC
	WHILE	;More prefixes exist
		LF	XSAC,ZCPZCP(XSAC)
		JUMPE	XSAC,FALSE
	DO
		EXEC	.SAIN
	OD
	SKIPL	OFFSET(ZPCPAR)(XTAC)
	BRANCH	.CSEN
	RETURN
	SUBTTL	.CPPD, End declarations in a prefixed block
Comment;

Purpose:	Transfer control to the statements of the outermost prefix.

Input:		None except XCB. Called by a JRST instruction.

Function:	Follow prefix chain from XCB.ZBIZPR to the outermost prefix
		and enter its statement coding (ZCPSTA).
;

.CPPD:	PROC
	LF	XZ,ZBIZPR(XCB)
	WHILE
		LF	,ZCPZCP(XZ)
		JUMPE	FALSE
	DO
		L	XZ,
	OD
	BRANCH	@OFFSET(ZCPSTA)(XZ)
	EPROC
	SUBTTL	.CPRS, Resume routine.
Comment;

Purpose:	To resume operation of the class instance given as a parameter.

Input:		XZBI (=XWAC1) is a reference to the class instance to be resumed.
Function:	Check that XZBI is not attached, operating or terminated, and
		not == NONE ( errors are signalled for these cases), then detach the
		current system component and enter XZBI at its reactivation point.

;

.CPRS:	PROC
	LOWADR
	IFG QSADEA,<
				edit(26)
	L	YSATOP(XLOW)	;[26] Update YSADEA to YSATOP
	HRRZM	YSADEA(XLOW)	;[26]
	>
	CFORBID
		edit(41)
	IF	;[41] XZBI==NONE
		CAIE	XZBI,NONE
		GOTO	FALSE
	THEN	CPERC	QDSCON,0,RESUME: object NONE
		RETURN
	FI	;[41]

	; INSPECT XZBI DO

	WLF	,ZDNLNK(XZBI)
	IF	;[41] Terminated
		IFOFFA	ZDNTER
		GOTO	FALSE
	THEN	CPERC	QDSCON,1,RESUME: terminated class instance
		RETURN
	FI	;[41]
	IF	;[41]
				edit(77)
		NOTDETACHED	;[77]
	THEN	CPERC	QDSCON,2,RESUME: attached class instance
		RETURN
	FI	;[41]
	SKIPA	XZ,XCB			; Follow operating chain to
	LOOP
		LF	XZ,ZDRZBI(XZ)	; nearest detached block instance
	AS
		SKIPL	OFFSET(ZDNDET)(XZ)	;[77]
		GOTO	TRUE
	SA
	CAMN	XZ,XZBI			; Was it THIS block?
		CPERR	3,RESUME: operating class instance
	HRL	XCB,(XPDP)		; Return address to XCB left half
	MOVSM	XCB,OFFSET(ZDRZBI)(XZ); Set reactivation point (ZDRZBI,ZDRARE)
	;Check operating chain for conflicts
	WHILE	; Static environment exists
		LF	XSAC,ZBIZPR(XZ)
		LFE	XSAC,ZCPSBL(XSAC)
		CAML	XSAC,[-QZDRZPB]
		GOTO	FALSE
	DO
		ADD	XZ,XSAC
		SKIPA	XZ,(XZ)
		LOOP
			LF	XZ,ZDRZBI(XZ)
		AS
			SKIPL	OFFSET(ZDNDET)(XZ)	;[77]
			GOTO	TRUE
		SA
		CAMN	XZ,XZBI
		CPERR	3,RESUME: operating class instance
	OD
	WHILE	;Reactivation point further in
		WLF	XOUT,ZDRARE(XZBI)
		TRNE	XOUT,-1
		GOTO	FALSE
	DO	;Descend into q.p. system by dynamic links
		HLR	XZBI,XOUT
	OD
	HLRZ	XCB,XOUT		; New XCB
	TRIMSTACK
	CALLOW
	BRANCH	(XOUT)			; Resume XZBI
	EPROC
	SUBTTL	.CPSP, Create an instance of a prefixed block
Comment;

Purpose:	To set up a prefixed block.

Input:		MOVEI	XSAC,prototype pointer
		EXEC	.CPSP

Output:		XRAC (=XWAC1) contains address of block instance.

Function:	Allocate block and display vector. Copy display
		from enclosing block, if any. If parameters exist,
		return to evaluation sequence, otherwise
		enter block coding.

Calls:		.CSEN
		.SADB
;

.CPSP:	PROC
	HRLI	XSAC,QZPB
	EXEC	.SADB
	MOVSI	(1B<%ZDNDET>)
	LFE	XWAC3,ZPREBL(XSAC)
	ADDI	XWAC3,QZDRZPB

	IF	;This is the outermost block
	JUMPL	XWAC3,FALSE
	THEN	;Use itself as enclosing detached block
		L	XTAC,XRAC
	ELSE	;find enclosing detached block
		SKIPA	XTAC,XCB
		LOOP
			LF	XTAC,ZDRZBI(XTAC)
		AS
			TDNN	OFFSET(ZDNDET)(XTAC)
			GOTO	TRUE
		SA
		;Copy the display from enclosing block (XCB)
		LI	XWAC5,(XCB)
		LI	XWAC4,(XRAC)
		LOOP	AS
			AOJG	XWAC3,FALSE
			LF	XIAC,ZDRZPB(XWAC5)
			SF	XIAC,ZDRZPB(XWAC4)
			SUBI	XWAC4,1
			SOJA	XWAC5,TRUE
		SA
	FI
	;Make surrounding detached block point to this prefixed block
	;(ZDRARE=0, ZDRZBI=this block), then mark this block as detached
	HRLZM	XRAC,OFFSET(ZDRZBI)(XTAC)
	IORM	OFFSET(ZDNDET)(XRAC)
	BRANCH	CPIN	;Initialise any prefixes
	EPROC
	LIT
	END