Trailing-Edge
-
PDP-10 Archives
-
decuslib10-05
-
43,50337/16/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 *****;