Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0078/rts/cs.mac
There is 1 other file named cs.mac in the archive. Click here to see a list.
	SUBTTL	SIMULA Run Time System, Central Part

; AUTHOR:	Lars Enderin
; PURPOSE:	To handle some run time tasks performed in almost all SIMULA programs

	SEARCH	SIMMAC,SIMMCR,SIMRPA
	SALL
	MACINIT
	ERRMAC(CS)
	RTITLE(CS)
	TWOSEG
	RELOC	400K

; CONTENTS
; --------
entry	.CSCA	; Make a copy of an array
entry	.CSEN	; Enter class, procedure or prefixed block declarations
entry	.CSEP	; Exit from function procedure, returning the result
entry	.CSER	; Enter a reduced subblock
entry	.CSES	; Exit from a switch thunk or pure procedure
entry	.CSEU	; Exit from unreduced subblock
entry	.CSGO	; Perform a general ('Worst case') GOTO statement
entry	.CSQU 	;* Check the qualification of a class instance
entry	.CSNA	; Allocate a new array object, given its type and subscript limits
entry	.CSRA 	;* Restore temporary results from accumulator stack record
entry	.CSSA	; Create accumulator stack record
entry	.CSSA.	;* Secondary entry to .CSSA called from RTS routines
entry	.CSSB	; Set up and enter subblock with its own block record
entry	.CSSC	; Evaluate switch
entry	.CSSN	; Set up procedure in the normal case (statically visible, declared)
entry	.CSSW	; Set up procedure in the other cases (formal,virtual,remote,connected)
		edit(23)
entry	.CSSW0	;[23] Same as .CSSW but only for formal or virtual without parameter list

; * means the procedure is not called from compiled code.




	EXTERN	.SAAB,.SAAR,.SADB,.SAGC
	SUBTTL	.CSCA, Copy ARRAY

COMMENT;
Purpose:	Make a copy of an array.
Input:		Xtop = address of array object to be copied.
		If an inline parameter of the form [n,,admap] to be passed
		to CSSA exists, Xtop==XWAC1+n, otherwise Xtop==XWAC1.
Output:		Address of the new array in Xtop, normally XWAC1 (see input).
Function:	Allocate a new array object by calling .SAAR.
		Copy the contents of the input array to the new array.
		Relocate base address (ZARBAD).
Calls:		.SAAR
;
	edit(13)
	edit(31)
.CSCA:	PROC
	LOWADR
	CDEFER
	L	XSAC,@(XPDP)		;[13] Check for inline parameter
	STACK	[0]			;[31] Normally no ac's to save
	ST	XWAC1,YOBJAD(XLOW)	;[31] Save input array address
	IF	;Inline parameter exists
		TLNE	XSAC,(777B8)
		GOTO	FALSE
	THEN	IF	;Any acs to save
			JUMPE	XSAC,FALSE
		THEN	;Save them
			HLRZ	XTAC,XSAC
			ST	XTAC,(XPDP)	;[31] remember how many ac's
			L	XWAC1(XTAC)	;[31] Save array address
			ST	YOBJAD(XLOW)
			EXEC	.CSSA.
		FI
		AOS	-1(XPDP)	;[31]
	FI
	L	XWAC1,YOBJAD(XLOW)	;[31R]
	LF	XTAC,ZARLEN(XWAC1)
	L	XWAC1,XTAC
	HRLI	XTAC,QZAR
	SETOM	YSANIN(XLOW)		;No initialization
	EXEC	.SAAR
	EXCH	XTAC,XWAC1
	L	XSAC,XWAC1
	HRL	XSAC,YOBJAD(XLOW)
	ADDI	XTAC,(XWAC1)
	BLT	XSAC,-1(XTAC)		;copy
	L	XWAC1			;Relocate base address
	SUB	YOBJAD(XLOW)
	ADDM	OFFSET(ZARBAD)(XWAC1)
	SETZM	YOBJAD(XLOW)		;Reset for GC control
	UNSTK	XTAC			;[31] Recall number of saved ac's
	ST	XWAC1,XWAC1(XTAC)	;[31] Put new array address in Xtop
	CENABLE
	SKIPE	XSAC,YCSZAC(XLOW)	;[13]
	BRANCH	.CSRA
	RETURN
	EPROC
	SUBTTL	.CSEN, Enter PROCEDURE, CLASS or PREFIXED BLOCK

Comment;

Purpose:	Enter coding of procedure, class or prefixed block
		when any parameters have been evaluated.

Input:		Block instance address in XRAC.
		Called by PUSHJ or a direct jump.

Exit:		To declaration coding of class, procedure or prefixed block.
;

.CSEN:	PROC
	LF	XSAC,ZBIZPR(XRAC)	; Prototype pointer
	LF	,ZDNTYP(XRAC)
	CAIE	QZBP			; Procedure has no prefix
L1():!	SKIPN	OFFSET(ZCPZCP)(XSAC)	; Find outermost prefix
	GOTO	L9
	LF	XSAC,ZCPZCP(XSAC)	
	GOTO	L1
	edit(257)
.CSENP:	;[257]
L9():!	LOWADR
	CFORBID
	UNSTK				; Return address from stack
	SF	,ZDRARE(XRAC)
	LI	XCB,(XRAC)		; XCB :- NEW block
	CALLOW
	BRANCH	@OFFSET(ZPCDEC)(XSAC)	; GOTO its declarations
	EPROC
	SUBTTL	.CSEP, Exit from function procedure

Comment;

Purpose:	Exit from a function and place the result in the two top ac's.

Input:		The result of the function as found in the current block.

Entry:		BRANCH	.CSEP

Output:		The function result, copied to the top two accumulators
		as specified by any accumulator stack saved at the
		function invocation.

Function:	The value of the procedure is copied from the first two words of
		the current block's data area. Two accumulators (XWAC&XWAC2)
		are loaded irrespective of the result type.
		Restore XCB of caller from ZDRZBI, return address from ZDRARE.
		If the procedure block has a ZAC record attached (ZDNACS is set)
		retrieve the address of the ZAC to XSAC and 
		call .CSRA. Return to the caller with
		the result in the top ac's.

Calls:		.CSRA
;
.CSEP:
	LD	XWAC1,ZBI%S(XCB)	;Function result to XWAC1 & XWAC2

CSEP1:	;ENTER HERE FOR SWITCH AND PROCEDURE
	LOWADR
	CDEFER
				edit(257)
	STACK OFFSET(ZDRARE)(XCB)
IFN QSADEA,<;[257]
	LF XSAC,ZBIZPR(XCB)
	LF XSAC,ZPCDLE(XSAC)
	SUBI XCB,-1(XSAC)
	LF XSAC,ZDRZAC(XCB,-1)
	IF  ;Deallocation allowed
	   CAMG XCB,YSADEA(XLOW)
	   GOTO FALSE
	THEN
	   IF ;Intermediate results were saved
		JUMPE XSAC,FALSE
	   THEN
		LI XCB,1(XSAC)	;Core to be cleared from ACS start to YSATOP
		XEC .CSRA	;Restore ac's
	   FI
	   LI XSAC,-1(XCB)	;Start of area to be cleared
	   HRLI XCB,(XSAC)
	   SETZM (XSAC)
	   EXCH XSAC,YSATOP(XLOW)
	   BLT XCB,-1(XSAC)
	ELSE
	   IF JUMPE XSAC,FALSE
	   THEN XEC .CSRA
	   FI
	FI
	HLRZ XCB,(XPDP)
	CALLOW
	RET
>
IFE QSADEA,<;[257]
	IF ;Intermediate results saved
	   IFOFF ZDNACS(XCB)
	   GOTO FALSE
	THEN;Restore them
	   LF XSAC,ZBIZPR(XCB)
	   LF XSAC,ZPCDLE(XSAC)
	   SUBI XCB,(XSAC)
	   LF XSAC,ZDRZAC(XCB)
	   XEC .CSRA
	FI
	HLRZ XCB,(XPDP)
	CALLOW
	RET
>
	SUBTTL	.CSER, Enter a reduced subblock

Comment;

Purpose:	Enter a reduced subblock, i e one without its own record.

Input:		Block number (state) in XSAC right half.
		XSAC left half is zero if XCB is the innermost unreduced
		subblock, otherwise the address of the innermost one.

Call:		EXEC	CSER

Function:	Resets variables to default values according to the map.
		Changes block state.
;
.CSER:	PROC
	LOWADR
	CDEFER
	L	XWAC4,XCB
	TLNE	XSAC,-1		;If XCB is not the innermost block,
	HLRZ	XWAC4,XSAC	;get block address from XSAC (LH)
	SF	XSAC,ZBIBNM(XWAC4)
	LF	XTAC,ZBIZPR(XWAC4);Find subblock map
	LF	XWAC1,ZPRMAP(XTAC)
	IF	;Non-zero map
		JUMPE	XWAC1,FALSE
	THEN	;Initialise variables according to the proper subblock map
		LSH	XSAC,2	;Multiply index by 4
		ADDI	XWAC1,(XSAC)
		LD	XWAC2,OFFSET(ZMPNOV)(XWAC1) ;ZMPNOV, ZMPNRV
		IF	;Any REF and/or ARRAY
			JUMPE	XWAC3,FALSE
		THEN	;Initialise these to NONE
			ADDI	XWAC3,(XWAC4)
			LI	NONE
			LOOP	ST	(XWAC3)
			AS	AOBJN	XWAC3,TRUE
			SA
		FI
		IF	;Any others
			JUMPE	XWAC2,FALSE
		THEN	;Initialize to zero
			ADDI	XWAC2,(XWAC4)
			LOOP	SETZM	(XWAC2)
			AS	AOBJN	XWAC2,TRUE
			SA
	FI	FI
	CALLOW
	RETURN
	EPROC	; .CSER ;
	SUBTTL	CSES

Comment;

Purpose:	Exit from a switch thunk or a pure procedure.

Input:		If called from SWITCH thunk,
		dynamic label address (ZDL) in XWAC1-XWAC2.
		Call by JRST.

Output:		Same as input.

Function:	Restore XCB of calling block from the switch or procedure
		block. Transfer to dynamic return (ZDRARE).

;
.CSES=	CSEP1	;As CSEP, except that result is already in XWAC1 & XWAC2
	SUBTTL	.CSEU, Exit from an Unreduced subblock
COMMENT;
	PURPOSE:	Exit from an unreduced subblock and deallocate
			its block record if possible

	INPUT:		Address to block address in display is
			passed in XSAC

	OUTPUT:		-

	FUNCTION:	Clear the entry in the display, reset the top-of-
			memory pointer if possible

	;
IFE	QSADEA,<.CSEU:	RFAIL	CSEU not implemented>
IFN	QSADEA,<
.CSEU:	PROC	;No save!
	HRRZ	XTAC,(XSAC)	;Clear display entry and load block adr
	SETZM	(XSAC)
	LOWADR	XWAC2
	CAMG	XTAC,YSADEA(XLOW)
	RETURN			; Deallocation not allowed
	HRRI	XSAC,1(XTAC)	;Prepare for BLT
	SETZM	(XTAC)
	HRL	XSAC,XTAC
	BLT	XSAC,@YSATOP(XLOW)
	HRRZM	XTAC,YSATOP(XLOW) ;Reset storage pointer
	RETURN
	EPROC
>
	SUBTTL	.CSGO, Perform a general ('Worst case') GOTO statement

Comment;

Purpose:	Perform a GOTO statement in the general case.

Input:		Dynamic label address (ZDL) in XWAC1-XWAC2.
		Call by PUSHJ.

Function:	Follow dynamic or static links from XCB until the target block
		is found or an error is signalled. Terminate encountered
		classes and check validity of transfer. Delete subblock
		entries from displays when jumping through.

;
QDEL1=	1B18
QDEL2=	1B19
QCHK=	1B20

.CSGO:	PROC
	ASSERT	<RIGHTHALF ZDLZBI>
	IF	;NULL label
		JUMPN	XWAC1,FALSE
	THEN	RETURN
	FI
	LOWADR
	CFORBID
	LI	XSAC,(XCB)
	SETZ	XTAC,
	WHILE	;target block not yet found
		CAIN	XSAC,(XWAC1)
		GOTO	FALSE
	DO
		LF	XWAC5,ZBIZPR(XSAC)	;Block prototype
		WLF	XWAC4,ZDNTYP(XSAC)	;Block condition
		TLZ	XTAC,QDEL1+QDEL2
		LF	XWAC3,ZDNTYP(,XWAC4)
		IF	;Class object encountered
			CAIE	XWAC3,QZCL
			GOTO	FALSE
		THEN
			SETONA	ZDNTER(XWAC4)	;Terminate it.
			IFOFFA	ZDNKDP(XWAC4)
			TLO	XTAC,QDEL2	;Can deallocate display.
			IFONA	ZDNDET(XWAC4)	;Leaving detached class?
			TLO	XTAC,QCHK	;Could be an error.
		ELSE
			TLO	XTAC,QDEL1+QDEL2
			IF	;Prefixed block
				CAIE	XWAC3,QZPB
				GOTO	FALSE
			THEN	;Transfer OK.
				TLZ	XTAC,QCHK
			ELSE
			IF	;Not procedure
				CAIN	XWAC3,QZBP
				GOTO	FALSE
			THEN	;Subblock, delete display entry
				LFE	XWAC6,ZPREBL(XWAC5)
				ADDI	XWAC6,(XSAC)
				SETZM	(XWAC6)
		FI	FI	FI
		TLNE	XTAC,QDEL2	;Get rid of ac stack if possible
		SETOFA	ZDNACS(XWAC4)
		WSF	XWAC4,ZDNTYP(XSAC)
		IF
			IFOFFA	ZDNDET(XWAC4)
			GOTO	FALSE
		THEN
			LFE	XWAC6,ZCPSBL(XWAC5)
			IF
				CAMG	XWAC6,[-QZDRZPB]
				GOTO	FALSE
			THEN
				CSERR	1,Undefined GOTO
			FI
			ADDI	XSAC,(XWAC6)
			L	XSAC,(XSAC)
		ELSE
			LF	XSAC,ZDRZBI(XSAC)
		FI
	OD
	TLNE	XTAC,QCHK
	    CSERR	2,Illegal GOTO
	LF	XCB,ZDLZBI(,XWAC1)	;Found nearest "display block"
	LFE	XWAC3,ZLDEBL(,XWAC1)
	ADDI	XWAC3,(XCB)		;Find the very nearest block
	L	XWAC4,(XWAC3)
	LF	XWAC5,ZDLBNM(,XWAC1)	;Set correct block state
	SF	XWAC5,ZBIBNM(XWAC4)
	HLRM	XWAC1,(XPDP)
	CALLOW
	RETURN
	EPROC
	SUBTTL	.CSNA, New array

Comment;

Purpose:	Allocate a new array object.

Input:		Subscript limits (lower,upper) in accumulators
		(XWAC1,XWAC2), (XWAC3,XWAC4),...
		Calling sequence:
		  EXEC	CSNA
		  XWD	array type, number of subscripts
		If ref array, prototype pointer in XSAC.

Output:		Array object address in XWAC1.

Function:	Save limits by calling .CSSA..
		Compute array object size, allocate array, store
		limits and dope vector. Initialize according to array type.

Calls:		.SAAR, .CSSA.

;
.CSNA:	PROC
	LOWADR
	CDEFER
	ST	XSAC,YCSWK3(XLOW)	;Save possible prototype address
	L	YCSZAC(XLOW)		;[41] Must save any earlier value
	ST	YOBJAD+QOBJAD-1(XLOW)	;[41]
	L	@(XPDP)
	HRRZM	YCSWK1(XLOW)		;Number of subscripts
	HLRZM	YCSWK2(XLOW)		;Type
	AOS	(XPDP)			;Account for inline parameter
	;MAKE PARAMETER FOR .CSSA.
	HRLZ	XSAC,YCSWK1(XLOW)	;Number of subscripts
	ASH	XSAC,1			;Two ac's per subscript
	HRRI	XSAC,[EXP 0,0]		;Map = 0 (no relocation)
	EXEC	.CSSA.			;Save all limits in a ZAC object.
	L	XTAC,YCSZAC(XLOW)
	MOVN	XSAC,YCSWK1(XLOW)	;Make AOBJN word in XSAC -
	HRLZ	XSAC,XSAC		;[-nsub,,addr of 1st saved subscr. val.]
	HRRI	XSAC,OFFSET(ZACSVA)(XTAC)
	LI	XTAC,1		;DOPE(1)
	LOOP	;Compute array size
		L	1(XSAC)	;Range=(UB-LB+1)*XTAC
		SUB	(XSAC)
		ADDI	1
		IF	JUMPG	FALSE
		THEN	CSERR	4,Upper bound of array LT lower bound
		FI
		IMUL	XTAC,
		CAILE	XTAC,777777
		    CSERR	3,Too big array
		STACK	XTAC		;Save range for later
	AS
		ADDI	XSAC,1		;Account for both bounds
		AOBJN	XSAC,TRUE
	SA
	TRIMSTACK
	L	XWAC1,YCSWK2(XLOW)	;Type
	CAIE	XWAC1,QLREAL		;Double length items?
	CAIN	XWAC1,QTEXT
	ASH	XTAC,1			;Then twice as many words
	L	XSAC,YCSWK1(XLOW)	;nsub
	ADDI	XTAC,(XSAC)		; * 2
	ADDI	XTAC,(XSAC)
	ADDI	XTAC,OFFSET(ZARLOW)+1(XSAC)
	CAILE	XTAC,777777
	    CSERR  3,Too big array
	HRLI	XTAC,QZAR
	IF	;REF ARRAY
		CAIE	XWAC1,QREF
		GOTO	FALSE
	THEN	;Initialize to NONE
		LI	NONE
		ST	YSANIN(XLOW)
		EXEC	.SAAR		;Allocate
		L	YCSWK3(XLOW)
		SF	,ZARZPR(XTAC)	;Store prototype pointer
	ELSE	;Initialize to zero
		SETZM	YSANIN(XLOW)
		EXEC	.SAAR		;Allocate
	FI
	L	XSAC,YCSWK1(XLOW)	;Number of subscripts
	SF	XSAC,ZARSUB(XTAC)
	SF	XWAC1,ZARTYP(XTAC)
	L	XWAC1,XSAC
	ASH	XWAC1,1
	L	XWAC3,YCSZAC(XLOW)
	ADDI	XWAC3,-2(XWAC1)
	LI	XWAC2,OFFSET(ZARLOW)(XTAC)
	ADDB	XWAC2,XWAC1
	ADDI	XWAC2,(XSAC)
	LI	XWAC7,1(XWAC2)	;Start of array elements
	SUBI	XSAC,1
	SETZ	XWAC6,		;Base address to be computed
	LOOP	;Store limits and dope vector, compute base address
		;Note backward loop
		LD	XWAC4,OFFSET(ZACSVA)(XWAC3)
		STD	XWAC4,(XWAC1)
		IF	JUMPLE	XSAC,FALSE
		THEN	;Compute dope vector element
			UNSTK	(XWAC2)	;from range
			IMUL	XWAC4,(XWAC2);and accumulated product
		FI
		SUB	XWAC6,XWAC4
		SUBI	XWAC3,2
		SUBI	XWAC2,1
		SUBI	XWAC1,2
	AS
		SOJGE	XSAC,TRUE
	SA
	L	XWAC1,YCSWK2(XLOW)
	CAIE	XWAC1,QLREAL	;Again double length if two-word items
	CAIN	XWAC1,QTEXT
	ADD	XWAC6,XWAC6
	ADD	XWAC6,XWAC7
	SF	XWAC6,ZARBAD(XTAC)
	L	XWAC1,XTAC
					edit(41)
	SETZ				;[41]
	EXCH	YOBJAD+QOBJAD-1(XLOW)	;[41]
	ST	YCSZAC(XLOW)		;[41]
	CALLOW
	RETURN
	EPROC	; .CSNA ;
	SUBTTL	.CSQU, Check qualification

Comment;

Purpose:	To check the qualification of a class instance against
		a given prototype.

Input:		Object reference in XWAC1, prototype
		address in XSAC. X0 left half is -1 if NONE
		is valid, right half is -1 if a subclass is valid.

Output:		-1 in XWAC1 if qualification accepted, otherwise zero.

Function:	See CAP PAGE 168. IF XWAC1 == NONE, result according to
		X0 left half. If ZBIZPR(XWAC1) == XSAC, result is TRUE.
		If XSAC found in prefix chain, result according to
		X0 right half.

;
.CSQU:	PROC
	IF	;NONE
		CAIE	XWAC1,NONE
		GOTO	FALSE
	THEN
		HLRE	XWAC1,X0
		RETURN
	FI
	STACK	XTAC
	LF	XTAC,ZBIZPR(XWAC1)
	SETZ	XWAC1,
	;Same prototype?
	CAIN	XTAC,(XSAC)
	GOTO	L2
	IF	;Subclass accepted
		TRNN	X0,-1
		GOTO	FALSE
	THEN	;Try prefixes
	L1():!	LF	XTAC,ZCPZCP(XTAC)
		JUMPE	XTAC,FALSE
		CAIE	XTAC,(XSAC)
		GOTO	L1
L2():!		SETO	XWAC1,
	FI
	UNSTK	XTAC
	RETURN
	EPROC	; .CSQU ;
	SUBTTL	.CSRA, Restore Accumulators

Comment;
Purpose:	Restores intermediate results from an
		acs object to the real ac-s and the pseudo ac-s. In
		addition, the result of a thunk or procedure is returned
		in the proper locations.

Input:		ACS address in XSAC

Entry:		EXEC .CSRA

Normal exit:	Return	(with intermediate results restored)

;


	edit(50)
	;[50] Overlapping BLT changed to use other ac's:-
	;     XWACL (last work ac) replaces XJ, X0 replaces XK in last BLT
	;     XK, XN are replaced by XIAC/XWAC1, XWAC2 otherwise


.CSRA:	PROC
	LF	XIAC,ZACNAC(XSAC)	; Number of values
	LI	XWACL,2(XIAC)		; Put XRAC & XRAC1 on top
	ADDI	XIAC,SVA(XSAC)
	STD	XRAC,(XIAC)
	LOWADR
	IF	;Any pseudo ac
		CAIG	XWACL,QNAC
		GOTO	FALSE
	THEN	;--- Restore pseudo ac-s first ---
		MOVSI	XWAC1,SVA(XSAC)
		HRR	XWAC1,YXACAD(XLOW)
		LI	XWAC2,-QNAC(XWACL)
		ADDI	XWAC2,-1(XWAC1)
		BLT	XWAC1,(XWAC2)
		;--- Shuffle real ac-s (top part below the rest)
		ADDI	XWACL,SVA-QNAC(XSAC)
		LI	XWAC1,SVA(XSAC)
		HRLI	XWAC1,SVA+QNAC(XSAC)
		BLT	XWAC1,-1(XWACL)
		LI	XWACL,QNAC
	FI
 ; --- All set to restore the real ac-s - go ahead
	HRLI	X0,SVA(XSAC)
	HRRI	X0,XWAC1
	BLT	X0,XWAC1-1(XWACL)
	SETZM	YCSZAC(XLOW)
	RETURN
	EPROC
	SUBTTL	.CSSA, Save Accumulators

COMMENT;
PURPOSE:	Saves temporary results from accumulators and YXAC (extended
		accumulators) in an acs object. If the remaining space
		does not suffice for another acs object, the garbage collector
		is invoked.

ENTRY:		EXEC	.CSSA		(from SIMULA code)
		XWD	number of saved words,address of map

		L	XSAC,@(XPDP)	from PHFA,PHFV, etc
		EXEC	.CSSA.

NORMAL EXIT:	RETURN

ERROR EXIT:	None

CALLED ROUTINES: .SAGC
;


	SVA=	<OFFSET(ZACSVA)>
	ASSERT <RIGHTHALF(ZACZAM)>


;---- Enter here from SIMULA code ----

.CSSA:	PROC
	L	XSAC,@(XPDP)	; Number ac-s,,acs map address
	AOS	(XPDP)		; Cause RETURN to skip parameter

;---- Enter here from RTS routines (with XSAC already loaded) ----

.CSSA.:	LOWADR
	SAVE	<X0,XSAC,XTAC>
	STACK	YDSCSW(XLOW)
	CFORBID
	L	X0,XSAC
	L	XSAC,YSATOP(XLOW); First free location
	WSF	,ZACNAC(XSAC)	; number of temporary results,,address of map
	HLRZ	XTAC,X0		; Number of temporary results
	CAILE	XTAC,QNAC	; Number of actual accumulators
	LI	XTAC,QNAC	; (at most QNAC)
	ADDI	XTAC,-1+SVA(XSAC); Save real ac-s in ZACSVA
	LI	SVA(XSAC)	; BLT control word in X0
	HRLI	XWAC1		; XWAC1 is lowest ac to be saved
	BLT	(XTAC)
	MOVSI	QZAC		; Indicate block type = "acs"
	WSF	,ZDNTYP(XSAC)
	LF	XN,ZACNAC(XSAC)	; Get number of ac-s to XN
	IF		;Any pseudo ac
		CAIG	XN,QNAC
		GOTO	FALSE
	THEN	;--- Move swapped-out (i e most recent) ac values to top
		LI	XJ,-QNAC(XN)	; Number of swapped-out ac's
		LI	XI,(XJ)
		LI	XK,SVA+QNAC(XSAC); Save swapped-out ac's here
		ADDI	XI,(XK)		; First unused pos in acs object
		HRLI	XK,SVA(XSAC)	; Take ac values from here
		BLT	XK,-1(XI)	; Now do the move
		; --- Now move extended ac-s to bottom of SVA
		HRL	XK,YXACAD(XLOW)
		HRRI	XK,SVA(XSAC)
		BLT	XK,-1-QNAC(XI)
	FI
	; --- All results saved - make room also for returned result
	; ---  from thunk or procedure
	L	YSATOP(XLOW)	; Acs object start
	ST	YCSZAC(XLOW)	; Save in global location
	LI	SVA+2(XN)
	ADDB	YSATOP(XLOW)
	SUB	YSALIM(XLOW)
	IF	;Not enough core left for another acs object
		JUMPLE	FALSE
	THEN	;Make room by collecting garbage
		EXEC	.SAGC
	FI

	UNSTK	YDSCSW(XLOW)
	RETURN
	EPROC		; --- End of CSSA ---
	SUBTTL	.CSSB, Set up and enter subblock with its own block record

Comment;

Purpose:	To create a block instance for an unreduced subblock
		and update the display of the current block.

Input:		XCB is the current block with a display.
		XSAC = the prototype address.

Function:	Allocate the subblock by calling .SAAB. Store its address
		at the proper level in the current display.

Calls:		.SAAB
;

.CSSB:	PROC
	LOWADR
	CDEFER
	EXEC	.SAAB		;Allocate the block
	LFE	XZ,ZPREBL(XSAC)	;Update the display
	ADDI	XZ,(XCB)
	ST	XZBI,(XZ)
	CALLOW
	RETURN
	EPROC	;.CSSB;
	SUBTTL	.CSSC, Evaluate switch


Comment;

Purpose:	Evaluate switch, i e return dynamic label according
		to switch index.

Input:		Dynamic switch address (ZDS) in XWAC1.
		Switch index in XWAC2.

Output:		Dynamic label address (ZDL) in XWAC1 & XWAC2.
		Zero if out of range.

Function:	If out of range, return with zero label.
		If simple label, compute dynamic label address from static
		label address and return.
		If designational expression, set up dummy block and
		display (similar to procedure setup) and enter switch
		thunk. Return will (eventually) be via .CSES.

Calls:		.SADB

;

.CSSC:	PROC
	LOWADR
	IFON	ZDNTER(XWAC1)	
	    CSERR    5,Cannot use switch in terminated class
	LF	XWAC10,ZDSZSR(,XWAC1)	;Switch record address
	LF	XWAC4,ZSRNEN(XWAC10)	;Number of elements
	IF	;Out of range
		JUMPLE	XWAC2,TRUE
		CAIG	XWAC2,(XWAC4)
		GOTO	FALSE
	THEN	;Return null label
		SETZB	XWAC1,XWAC2
		GOTO	L9
	FI
	SUBI	XWAC2,(XWAC4)
	ASH	XWAC2,1
	ADDI	XWAC2,(XWAC10)
	LD	XWAC3,-2(XWAC2)		;ZSL to XWAC3-XWAC4
	LFE	XWAC5,ZSLENB(,XWAC3)
	ADDI	XWAC5,(XWAC1)		;Enclosing "display block"
	L	XWAC5,(XWAC5)
	LF	XWAC6,ZSLADP(,XWAC3)
	IF	;Simple label
		JUMPGE	XWAC3,FALSE
	THEN	;Compute dynamic label (ZDL)
		SF	XWAC5,ZDLZBI(,XWAC1)
		SF	XWAC6,ZDLCAD(,XWAC1)
		L	XWAC2,XWAC4	;!!! SECOND ZDL WORD COPY OF ZSL!!!
		SKIPE	XSAC,YCSZAC(XLOW)	;Restore XWAC1 if necessary
		EXEC	.CSRA
	ELSE	;Set up block and display from prototype,
		;enter switch thunk
		LF	XTAC,ZDSZBI(,XWAC1)	;Recover environment of switch
		LI	XSAC,OFFSET(ZSRZPC)(XWAC10)
		HRLI	XSAC,QZBP
		EXEC	.SADB
		;---- Copy display from environment ---
		LFE	XWAC7,ZPREBL(XSAC)
		ADDI	XWAC7,QZDRZPB	;-Number of display elements
		LI	XSAC,(XWAC1)	;Base of new block
		LOOP
			AOJG	XWAC7,FALSE
			LF	,ZDRZPB(XTAC)
			SF	,ZDRZPB(XSAC)
		AS
			SUBI	XSAC,1
			SOJA	XTAC,TRUE
		SA
		HRRZ	(XPDP)
		SF	,ZDRARE(XWAC1)
		CFORBID
		ASSERT <RIGHTHALF ZSLADP>
		HRRM	XWAC3,(XPDP)	;Return address
		LI	XCB,(XWAC1)
		CALLOW
	FI
L9():!	RETURN
	EPROC	;.CSSC;
	SUBTTL	.CSSN, set up normal procedure

Comment;

Purpose:	Set up normal procedure instance with a known static environment.
		.SADB allocates both display record and block instance.
		The new display is obtained from XCB. If the procedure
		has no parameters, control is transferred directly to .CSEN
		which sets the dynamic return link and enters the declarations
		of the procedure.

Entry:		MOVEI	XSAC,prototype
		EXEC	.CSSN

Normal exit:	Control goes back to SIMULA code with XRAC pointing to
		the new procedure instance, if parameters have to be calculated.
		Otherwise, if no parameters exist, control goes to .CSEN,
		which will store the return address and enter the declarations
		of the procedure.

Error exit:	None

Calls:		.CSEN,.SADB
;

.CSSN:	PROC
	HRLI	XSAC,QZBP	; Type="procedure"
	EXEC	.SADB		; Allocate display and block, result in XRAC
			edit(257)
	LI XWAC5,(XCB)
	LFE XWAC3,ZPREBL(XSAC)
	Q==5
CSDICO:	;Entry from CSSW
	IF ;Display has less than Q+QZDRZPB levels
	    CAMGE XWAC3,[-Q-QZDRZPB]
	    GOTO FALSE
	THEN;Use straight code for speed
	    ASH XWAC3,1
	    Q1==2*<Q+QZDRZPB>
	    GOTO .+1+Q1(XWAC3)
	    Q2==1-Q-QZDRZPB
		REPEAT Q,<
	    L Q2(XWAC5)
	    ST Q2(XRAC)
	    Q2==Q2+1
		>
	ELSE;Use BLT
	    LI XWAC4,1(XWAC5)
	    ADD XWAC4,XWAC3
	    ADDI XWAC3,1(XRAC)
	    HRLI XWAC3,(XWAC4)
	    BLT XWAC3,-QZDRZPB(XRAC)
	FI
	SKIPL OFFSET(ZPCPAR)(XSAC)
	  BRANCH .CSENP
	RET
	PURGE Q,Q1,Q2
	EPROC
	SUBTTL	.CSSW, .CSSW0,  set up worst case

Comment;

Purpose:	Set up procedure instance for a remote, connected,
		formal or virtual procedure.
		.SADB allocates both display record and block instance. The
		new display is obtained from the two blocks ZDPEBI and ZDPZBI
		of the dynamic procedure address passed as parameter.
		If the procedure has no parameters, control is transferred
		directly to .CSEN which sets the dynamic return link and
		enters the declarations of the procedure.

Entry:		ZDP instance in Xtop, Xtop+1
		EXEC	.CSSW   or   EXEC  .CSSW0
		XWD	N,ADMAP	! Xtop == XWAC1+N

Normal exit:	Control goes back to SIMULA code with XRAC pointing to
		the new procedure instance, if parameters have to be calculated.
		Otherwise, if no parameters exist, control goes to .CSEN,
		which will store the return address and enter the declarations
		of the procedure.

Error exit:	None

Calls:		.CSEN,.SADB
;

	edit(23)
	;[23] New entry to check if parameters missing for formal or virtual
	;  procedure calls without parameter list

.CSSW0:	PROC
	HLRZ	XTAC,@(XPDP)	;Number of saved AC:s to find Xtop
	LF	XSAC,ZDPZPR(XTAC,XWAC1)
	SKIPGE	OFFSET(ZPCPAR)(XSAC)	;ZPCPAR = bit 0 on if formal parameteres
					; present
	CSERR	7,Parameters missing




.CSSW:	LOWADR
	STD	XWAC1,YOBJAD(XLOW)	;Assume simplest case
	L	X0,@(XPDP)		; Get inline parameter
	IF	;Any intermediate results
		JUMPE	X0,FALSE
	THEN
		HLRZ	XTAC,X0		;Number of interm. results
		LD	XSAC,XWAC1(XTAC);Save ZDP
						edit(14)
		CAM	(XSAC+OFFSET(ZDPEBI))	;[14] Cause "Object NONE"
		STD	XSAC,YOBJAD(XLOW)
		L	XSAC,X0
		EXEC	.CSSA.
	ELSE
		CAM	(XWAC1+OFFSET(ZDPEBI))	;[14] Cause "Object NONE"
	FI
	AOS	(XPDP)
	;Check for .PHPT call - error if procedure has no formal parameter
	L	@(XPDP)
	LF	XSAC,ZDPZPR(XLOW,YOBJAD)
	IF	;Zero in left half, we have a call on .PHPT
		TLNE	-1
		GOTO	FALSE
	THEN	;We must check for any parameter
		AOS	(XPDP)	;Account for this word also
			edit(257)
		SKIPL	OFFSET(ZPCPAR)(XSAC)	;[257]
		  CSERR	6,Actual procedure has no parameters
	FI
	HRLI	XSAC,QZBP	; Type="procedure"
	EXEC	.SADB		; Allocate display and block, result in XRAC
	LF	XWAC5,ZDPZBI(XLOW,YOBJAD); Initialize for display copy
	LFE	XWAC3,ZPREBL(XSAC)
				edit(257) ;START
	LI	XWAC4,(XRAC)
	ADD	XWAC4,XWAC3
	LF	,ZDPEBI(XLOW,YOBJAD)	; Nearest enclosing block
	ST	1(XWAC4)
				edit(254)
	SETZM	YOBJAD(XLOW)	;[254]
	SETZM	YOBJAD+1(XLOW)	;[254]

; Now the display is copied from ZDPZBI, except for innermost level,
; which was put in by .SADB, and static environment, which is ZDPEBI.

	AOJA	XWAC3,CSDICO	;[257]
				edit(257) ;END
	EPROC
	LIT
	END	;***** CS *****;