perm filename ARYSER[S,AIL]5 blob
sn#072696 filedate 1973-11-20 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00008 PAGES VERSION 17-1(4)
RECORD PAGE DESCRIPTION
00001 00001
00002 00002 HISTORY
00004 00003 Array Stuff
00011 00004 bexit & stkuwd
00019 00005 array info & the like
00023 00006 the procedure item routines
00027 00007
00033 00008
00036 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000004 ⊗;
COMMENT ⊗
VERSION 17-1(4) 11-20-73 BY RFS
VERSION 17-1(3) 11-20-73 BY rfs MAKE LOWER BOUND > UPPER BOUND CONTINUABLE
VERSION 17-1(2) 10-14-73 BY RHT BUG #OP#
VERSION 17-1(1) 10-14-73 BY RHT BUG #OL#-- TYPO IN APPLY
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 **** **** VERSION 17-1(0)
VERSION 16(4) 7-24-73 BY RHT BUG #NG# SIMPLE PROC GO TO NS PROC SHOULD SORT OF WORK
VERSION 16(3) 7-24-73 BY RHT BUG #NF# -- FOUND TBITS USE LURKING IN STKUWD
VERSION 16(2) 7-14-73 BY RHT ADD APPLY$
VERSION 16(1) 7-13-73 BY RHT MAKE APPLY RETURN A VALUE LIKE IT IS SUPPOSED TO
⊗;
COMMENT ⊗Array Stuff ⊗
;ARYDIR, ARRPDL, AND FRIENDS ARE NO MORE
DSCR LRCOP, ARCOP
⊗
COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN>>
,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
,<ARRAY ALLOCATION ROUTINES>)
HERE(LRCOP)
HERE(ARCOP)
;;#HO# 6-7-72 DCS ALLOW BOTH ADDRS TO BE RETURNED
PUSH P,B
PUSH P,C ;SOME WORK SPACE.
PUSH P,-3(P) ;ARRAY TO BE COPIED
PUSHJ P,..ARCOP ;COPY IT
POP P,C
POP P,B
SUB P,X22
JRST @2(P) ;DONE
↑↑..ARCOP:
;;#HO#
HRRZ A,-1(P) ;THE ARRAY TO BE COPIED.
SKIPGE -2(A)
SUBI A,1 ;FOR STRING ARRAYS.
HLRE B,-1(A) ;NUMBER OF DIMENSIONS.
MOVMS B ;ABSOLUTE VALUE.
IMUL B,[-3]
ADDI A,-2(B) ;A NOW POINTS TO "CORGET" GUY.
MOVN C,-1(A) ;SIZE
SUBI C,3 ;TO ACCOUNT FOR BOOKEEPING.
PUSHJ P,CORGET
ERR <NO ROOM FOR ARRAY>
PUSH P,B
HRLI B,(A) ;MAKE UP A BLT WORD.
ADDI C,(B)
BLT B,-1(C) ;COPY THE WHOLE ARRAY.
POP P,B ;BECAUSE BLT DESTROYS ITS.
HRRZS A ;SINCE THE ADDI ABOVE LEFT STUFF IN LEFT HALF.
MOVNS A
ADDI A,(B) ;A HAS NEW-OLD DIFFERENCE.
ADDM A,(B) ;THESE HAVE TO BE RELOCATED.
ADD A,-1(P) ;NEW ARRAY DESCRIPTOR.
HRRM A,-2(B) ;FOR STRING GARBAGE COLLECTOR.
MOVE C,-1(P) ;ARRAY THAT WAS COPIED.
SKIPGE -2(C) ;WAS IT A STRING ARRAY?
SOS -2(B) ;BACK IT UP ONCE.
SUB P,X22
JRST @2(P) ;ALL DONE.
DSCR LRMAK
⊗
HERE(LRMAK)
DSCR ARMAK
⊗
HERE (ARMAK)
BEGIN ARMAK
PUSHJ P,SAVE
HRRZ A,-1(P) ;#DIMENSIONS
MOVEI B,-2(P) ;→BOUNDS(n)
MOVEI C,1
MAKLUP: SOJL A,SIZDUN ;DONE GETTING TOTAL SIZE
MOVE D,(B) ;UPPER BOUND
ADDI D,1 ;PLUS ONE.
SUB D,-1(B) ; -LOWER BOUND IS TOTAL SIZE
SKIPG D ;MUST BE POSITIVE
ERR {ARRAY lower bound > upper bound},1,SIZ0
IMUL C,D ;COLLECT SIZE
SIZ0: SUBI B,2 ;LOOK AT NEXT
JRST MAKLUP
SIZDUN: ; MOVEI C,SIZE DESIRED -- ALREADY THERE
SKIPGE -1(P) ;IF #DIMS POSITIVE, THEN NOT STRING ARRAY
LSH C,1 ;MULTIPLY BY TWO FOR STRINGS.
PUSH P,C ;SAVE SIZE OF ARRAY ITSELF
HRRZ A,-2(P) ;#DIMENSIONS AGAIN
IMULI A,3 ;SIZE OF ARRAY DESCRIPTOR TABLE
ADDI C,2(A) ;ADD TO SIZE OF AREA NEEDED
AGIN: PUSH P,C ;SAVE IT
PUSHJ P,CORGET ;ARRAY
ERR <ARRAY no room>
GOTARR: POP P,C ;TOTAL SIZE AGAIN
MOVE D,B ;SAVE ADDRESS
HRRZ TEMP,B
ADD TEMP,C
POP P,C ;ARRAY SIZE
PUSH P,B ;SAVE →ARRAY BLOCK
SETZM (B)
HRLS B
ADDI B,1
BLT B,-1(TEMP) ;CLEAR ARRAY
HRRZI B,(D) ;GET ADDRESS BACK
HRRZ TEMP,-2(P) ;#DIMENSIONS AGAIN
SKIPGE -2(P) ;STRING ARRAY?
MOVNS TEMP ; YES
HRL C,TEMP ;#DIMS, TOTAL SIZE (#DIMS NEG IF STRING)
PUSH P,C ;SAVE INFORMATION WORD
COMMENT ⊗
LET D→NEXT WORD INTO TABLE, A=COUNT OF DIMENSIONS LEFT,
C=ACCUMULATING TOTAL SIZES (AGAIN)
B→CURRENT DESCRIPTIONS (IN STACK), TEMP USED FOR MOVING THINGS
⊗
ADDI B,1 ;LEAVE ROOM FOR ADDRESS WORD
HRRZ A,-3(P) ;#DIMS
MOVE LPSA,A ;PREPARE FOR SUBRT RETURN
LSH LPSA,1
ADDI LPSA,2
HRLS LPSA
MOVEI D,-4(P) ;→INFO
;MOVE D,[FIRST WORD] ;ALREADY THERE
MOVEI C,1 ;MULTIPLY FACTOR
MOVEI X,0 ;ACCUMULATE TOTAL DISPLACEMENT
STOLUP: SOJL A,STODUN
MOVEW (<1(B)>,<(D)>) ;UPPER BOUND
ADDI TEMP,1
SUB TEMP,-1(D) ;TOTAL SIZE
MOVEM C,2(B) ;AND MULTIPLY FACTOR
IMUL C,TEMP ;TEMP HAS SIZE THIS DIMENSION
MOVEW (<(B)>,<-1(D)>) ;STORE LOWER BOUND
IMUL TEMP,2(B) ;COLLECT TOTAL DISPLACEMENT
ADD X,TEMP ;IN X
ADDI B,3
SUBI D,2
JRST STOLUP ;UPDATE POINTERS AND LOOP
STODUN: POP P,(B) ;INFO WORD
ADDI B,1 ;WILL POINT AT FIRST DATA WORD
POP P,TEMP ;→BLOCK HEAD
HRRZM B,-2(TEMP) ;STORE WHERE STRNGC CAN FIND IT
SKIPGE -1(B) ;IS IT A STRING ARRAY?
HRROI B,1(B) ;YES, POINT AT 2D WORD OF FIRST ELEMENT
MOVEM B,RACS+1(USER) ;RESULT
JUMPGE B,NSTG ;STRING ARRAY?
LSH X,1 ; YES, DOUBLE DISPLACEMENT
NSTG: SUB B,X ;ARRAY ADDR - TOTAL DISPLACEMENT
HLL B,RACS+1(USER) ;-1 IF STRING, 0 OTHERWISE
MOVEM B,(TEMP) ;SAVE IN (0,0,0) WORD
JRST RESTR
BEND ARMAK
DSCR ARYEL
⊗
HERE(ARYEL)
BEGIN ARYEL
HRRZ B,-1(P)
POP P,-1(P) ;PUT POPJ ADDRESS BACK FOR CORREL.
SKIPGE -2(B)
SUBI B,1 ;COMPUTE THE HEADER ADDRESS.
HLRE A,-1(B)
MOVMS A
IMUL A,[-3]
ADDI B,-2(A)
HRRZS B
JRST CORREL ;RELEASE IT.
BEND
COMMENT ⊗ bexit & stkuwd ⊗
DSCR BEXIT
PARM -- XWD #LEVELS-1,LVI ADDRESS IN LPSA
DES -- RELEASES STROAGE FOR BLOCKS -- REPLACES THE OLD ARRREL
SID -- MANGLES ALL REGISTERS
⊗
HERE(BEXIT)
BEGIN BEXIT
BKCNT←5
BKPTR←6
TPTR←7
EN←10 ;ALSO USED BY STKUWD
PDA←11 ;THIS IS USED BY STKUWD, BUT SOME OF THE LVIDAC ROUTINES MUST SAVE IT
;SINCE THEY ARE SOMETIMES USED BY STKUWD -- THIS IS CHEAPEST WAY
PUSH P,A ;SAVE A
HLRE BKCNT,LPSA ;SAVE COUNT
HRRZ BKPTR,LPSA ;POINT
MOVE TPTR,[POINT 4,EN,3] ;BYTE PTR FOR TYPE
NXTEN: MOVE EN,(BKPTR) ;PICK ONE UP
LDB A,TPTR ;PICK UP TYPE
PUSHJ P,@[ ↑↑LVIDAC: DRYROT
RARY ;1
RARY ;2
SLFRE ;3 -- SET OR LIST
LAFRE ;LEAP ARRAY OF SETS OR LISTS
FEVAR ;5 FOR EACH CONTROL VARIABLE
KLIST ;6
CTEXTT ;7 CONTEXT
CLNUP ;10
DRYROT ;11
DRYROT ;12
DRYROT ;13
DRYROT ;14
DRYROT ;15
DRYROT ;16
BKE ;17 END OF BLOCK AREA
](A)
AOJA BKPTR,NXTEN ;GET NEXT
DRYROT: ERR <DRYROT: BEXIT>
POPJ P,
RARY: SKIPN C,@EN
POPJ P,
EXCH C,(P) ;CLEVER WAY TO FIX THE STACK FOR CALL TO
;ARYEL
PUSH P,C
SETZM @EN ;SAY IT IS GONE
JRST ARYEL ;MAKE IT THE TRUTH
SLFRE: SKIPN A,@EN ;
POPJ P,
SETZM @EN ;ZERO OUT THE DESCRIPTOR
PUSH P,5 ;SAVE IT
PUSH P,6
MOVEI 5,0 ;FOR RECLAIMER
PUSHJ P,RECQQ ;SINCE SET
POP P,6
POP P,5
POPJ P,
CTEXTT: SKIPN A,@EN ;CONTEXT EMPTY?
POPJ P, ;YES
PUSH P,EN ;CONTEXT ADDRESS
PUSHJ P,ALLFOR ;FORGET EVERYTHING
POPJ P,
LAFRE: SKIPN A,@EN ;ARRAY PTR
POPJ P, ;NOBODY HOME
PUSH P,A
SETZM @EN
PUSHJ P,ARRRCL ;JRL'S MAGICAL SET ARRAY ZAPPER
EXCH A,(P) ;CLEVER TRICK AGAIN
PUSH P,A ;
JRST ARYEL ;GIVE UP THE SPACE
BKE: SOJGE BKCNT,GETNXT ;DO WE NEED TO DO MORE?
MOVE A,-1(P)
SUB P,[XWD 3,3] ;
JRST @1(P) ;NO
GETNXT: MOVEI BKPTR,@EN ;GET LINK
SOJGE BKPTR,CPOPJ ;WILL COMPENSATE FOR AOS
ERR <DRYROT: BEXIT>
FEVAR: SKIPN A,@EN
CPOPJ: POPJ P,
PUSH P,PDA
PUSH P,BKCNT
PUSH P,BKPTR
PUSH P,TPTR
; NOW CALL LEAP TO RELEASE FOREACH
MOVEI 5,47 ;CHANGED (11-30-72) TO REFLECT NEW INDICES
PUSHJ P,LEAP
POP P,TPTR
POP P,BKPTR
POP P,BKCNT
POP P,PDA
POPJ P,
KLIST: SKIPN A,@EN
POPJ P,
ERR <UNTERMINATED PROCESS DEPENDS ON A BLOCK BEING EXITED
MAY CONTINUE >,1
POPJ P,
CLNUP: PUSH P,PDA
PUSH P,BKCNT
PUSH P,BKPTR
PUSH P,TPTR
PUSHJ P,(EN) ;CALL THE PROUCEDURE
POP P,TPTR
POP P,BKPTR
POP P,BKCNT
POP P,PDA
POPJ P,
BEND BEXIT
HERE (STKUWD)
BEGIN STKUWD
DSCR STKUWD
DES THIS PROCEDURE UNWINDS THE STACK TO ESTABLISH A CORRECT DISPLAY AND
LEXIC LEVEL.
PAR LPSA=XWD CORRECT LL,CORRECT DL
SID MANGLES YOUR ACS (EXCEPT F, P, SP -- WHICH ARE PROPERLY FIXED UP)
⊗
CDLSAV←5
LLFGR←6
SIN←7
EN←10
PDA←11
MOVE USER,GOGTAB
POP P,STKURT(USER) ;REMEMBER RETURN ADDRESS
HRRZM LPSA,CDLSAV ;
HLROM LPSA,LLFGR ;SET UP PARAMETERS FOR USE
PLOOP: HLRZ PDA,1(RF) ;PICK UP PROC DESC ADDRESS
;;#LP# (25 FEB 73)1 OF 1 -- RHT -- MUST CHECK FOR GO TO OUT OF PROCESS
CAIN PDA,0 ;IS THIS THE BITTER END
ERR <GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
;;#LP#
;;#NG# -- RHT ALWAYS ADJUST STACKS BEFORE DO LVI NOW!
MOVE SP,2(RF) ;OLD OLD SP
HLLZ A,PD.DSW(PDA) ;EXTRA SS DISPL NEED
HLR A,A ;BOTH SIDES
ADD SP,A ;
HRRZ A,PD.DSW(PDA) ;ARITH STK DISPL
ADDI A,(RF) ;+RF
HRRZ B,P ;WHERE WE ARE NOW
SUB B,A ;HOW FAR BACK TO GO
HRL B,B ;BOTH SIDES
SUB P,B ;TRIMMED BACK
;;#NG#
CAMN PDA,CDLSAV ;IS THIS THE PARENT ???
HRRZS LLFGR ;USE THIS AS A FLAG
HRRZ SIN,PD.LLW(PDA) ;POINTER AT LVI INFO
NXTEN: SKIPN EN,(SIN) ;A ZERO SAYS
JRST EOPD ;WE ARE AT END OF LOC VAR INF
TPGET: LDB A,[POINT 4,EN,3] ;TYPE FIELD
CAIN A,17 ;IGNORE END OOF BK ENTRIES
AOJA SIN,NXTEN
JUMPL LLFGR,DOIT ;IF NOT AT RIGHT DL, ZAP EM ALL
LDB B,[POINT =9,EN,=12] ;LL FIELD
CAMG B,LLFGR ;IF LEX LEV IS LOW ENOUGH
AOJA SIN,NXTEN ;LET HIM LIVE -- VERY INEFFICIENT CODE
DOIT: PUSHJ P,@LVIDAC(A) ;CALL APPROPRIATE ROUTINE
AOJA SIN,NXTEN
EOPD: JUMPL LLFGR,EOPD.1 ;RETURN TEST
MOVE USER,GOGTAB ;
JRST @STKURT(USER)
EOPD.1: HRRZ SIN,PD.DLW(PDA) ;NOW HAVE TO CLEAR OUT SET FORMALS
HRRZ B,PD.NPW(PDA) ;#ARITH +1
MOVE C,RF ;F REG
SUBI C,1(B) ;C← →→ 1 BEFORE 1'ST ARITH PARM
PARLP: SOJLE B,ADJSKS ;COUNT DOWN # ARGS
AOS C ;POINT AT NEXT
MOVE B,(SIN) ;TYPE CODE
;;#NF# RHT 24 JULY 73 THIS PIECE OF CODE WAS STILL USING TBITS
TLC B,SETYPE⊗5 ;VALUE SET MUST BE RELEASED
TLNN B,REFB!ITEMB!PROCB ;THESE ARE NOT RELEASED
TLNE B,MSK6BT ;CHECK THE SET CODE
;;#NF#
AOJA SIN,PARLP ;IF NOT VALUE SET, NO PROBLEMS
MOVEI EN,(C) ;EN←← PTR TO SET
;; BY JRL 8-31- 72 FOLLOWING INSTRUCTION WAS PUSHJ P,@LVIDAC+4
PUSHJ P,@LVIDAC+3 ;CALL SET RELEASER
AOJA SIN,PARLP ;GO ON TO NEXT
ADJSKS: HRRZ RF,(RF) ;BACK A DYNAMIC LINK
;;#NG# -- USED TO ADJUST STACKS HERE
JRST PLOOP ;
BEND STKUWD
COMMENT ⊗ array info & the like ⊗
DSCR INTEGER←ARRINFO(ARRAY,CODE);
CAL SAIL
⊗
HERE (ARRINFO)
BEGIN ARRINFO
MOVE A,-2(P) ;ARRAY ADDRESS
SKIPGE -2(A) ;STRING ARRAY?
SUBI A,1 ; YES, BACK UP FOR IT
SKIPGE TEMP,-1(P) ;CONTROL PARAMETER
JRST [HLRE A,-1(A) ;WANTS NUMBER OF DIMENSIONS
JRST RSINFO]
JUMPE TEMP,[HRRZ A,-1(A) ;WANTS TOTAL SIZE
JRST RSINFO]
; WANTS A BOUND
ROT TEMP,-1 ;SAVE LOW ORDER BIT AS SIGN
MOVNI LPSA,3 ;GET DISPLACEMENT INTO ARRAY TABLE
IMULI LPSA,(TEMP)
SKIPGE TEMP ;WANT UPPER OR LOWER BOUND
SUBI LPSA,4
HRLI A,LPSA
MOVE A,@A ;GET THE REQD BOUND
RSINFO:
SUB P,X33
JRST @3(P)
BEND ARRINFO
DSCR ARRBLT(@DEST,@SOURCE,LENGTH);
CAL SAIL
⊗
HERE (ARRBLT)
BEGIN ARRBLT
HRRZ TEMP,-3(P)
HRL TEMP,-2(P)
SOS LPSA,-1(P)
ADDI LPSA,(TEMP)
BLT TEMP,(LPSA)
SUB P,X44
JRST @4(P)
BEND ARRBLT
DSCR ARRTRAN(DEST ARRAY,SOURCE ARRAY);
CAL SAIL
⊗
HERE (ARRTRAN)
BEGIN ARRTRAN
HRRZ TEMP,-2(P) ;DEST ARRAY ADDR
HRRZ LPSA,-1(P) ;SOURCE ARRAY ADDR
SKIPL -2(TEMP) ;STRING ARRAY?
JRST NSTR ; NO
SUBI TEMP,1
SUBI LPSA,1
NSTR: HRL TEMP,LPSA ;BLT WORD
HRRZ LPSA,-1(LPSA) ;SOURCE SIZE
HRRZ USER,-1(TEMP)
CAMLE LPSA,USER
HRRZ LPSA,USER
ADDI LPSA,-1(TEMP) ;TERMINATION WORD
BLT TEMP,(LPSA)
SUB P,X33
JRST @3(P)
BEND ARRTRAN
ENDCOM(ARY)
IFE ALWAYS, <
COMPIL(DM1,<RECQQ,ARRRCL,LEAP>,,<DUMMY LEAP BEXIT TARGETS>)
↑↑RECQQ:
↑↑ARRRCL:
↑↑LEAP:
ERR <DRYROT-LIBRARY>
ENDCOM(DM1)
COMPIL(DM2,<SPRPDA,RESUME,TERMIN,SPROUT,DADDY,CURSCB>,,<DUMMY PROCESS VARIABLES>)
↑↑SPRPDA:
↑↑RESUME:
↑↑TERMIN:
↑↑SPROUT:
↑↑DADDY:
↑↑CURSCB:
ERR <DRYROT-LIBRARY>
ENDCOM(DM2)
COMPIL(DM3,<ALLFOR>,,<DUMMY BACKTRACKING BEXIT TARGET>)
↑↑ALLFOR:
ERR <DRYROT-LIBRARY>
ENDCOM(DM3)
COMPIL(DM4,<APPL$Y>,,<DUMMY APPLY PD ENTRY>)
↑↑APPL$Y:
.+1
ERR <DRYROT-LIBRARY>
ENDCOM(DM4)
>;IFE ALWAYS
COMMENT ⊗ the procedure item routines
⊗
COMPIL(PIT,<PITCOP,PITBND,APPLY,PITDTM>,<GINFTB,INFTB,DATM,GDATM,GOGTAB,RECQQ>
,<PROCEDURE ITEM ROUTINES>,<APPL$Y>)
COMMENT ⊗ APPLY$ IS NOT MADE AN ENTRY. HOWEVER IT IS INTERNALED. THUS
PIT WILL NOT BE LOADED SIMPLY BECAUSE OF THE EXTERNAL REQUEST IN SAIPRC
FOR APPLY$ ⊗
BEGIN PITS
FLAG←0;
PDA ← 4
NPW ← 5
FPTR←6
FRM←7
APTR←10
GLOB <
GBRK←←6000
>;GLOB
DSCR PITBND,PITCOP
CAL
PUSH P,DITM
PUSH P,XXX
PUSHJ P,PITBND <OR PITCOP>
PARM DITM IS ITEM TO BE MADE INTO PROCEDURE ITEM
FOR PITBND, XXX IS PDA OF PROC TO BE BOUND
FOR PITCOP, XXX IS PROCEDURE ITEM NUMBER
DES PUTS INTO DITM'S DATUM: XWD STATIC LINK,PDA &SETS DITM'S TYPE TO PITTYP
SID MANGLE TEMP,LPSA,USER,B,C
⊗
HERE (PITBND)
HRRZ LPSA,-1(P) ;PICK UP PDA
HRRZ TEMP,PD.PPD(LPSA) ;PARENT'S PDA
;;#LM# ↓ WAS A SKIPE
SKIPN PD.PPD(TEMP) ;IF DADDY IS THE GLOBAL MAN (IE
JRST PUTDTM ;THE OUTER BLOCK -- INDICATED BY HIS
;HAVING NO FATHER -- THEN DONT LOOK FOR
;A STATIC LINK -- YOU WILL USE 0
SKIPA USER,RF ;
CTXTLP: HRRZ USER,(USER) ;GO UP A LINK
HLRZ B,1(USER) ;PDA AT THIS LEVEL. NOTE WE
CAME TEMP,B ;FIRST LOOK AT THIS GUY
JRST CTXTLP ;NOT THE ONE
HRL LPSA,USER ;NOW LPSA IS SL,,PDA
JRST PUTDTM ;GO PUT IN THE DATUM
HERE(PITCOP)
MOVE C,-1(P) ;PICK UP ITEM NO INTO B
PUSHJ P,PITDGT ;GET DATUM
PUTDTM: MOVE C,-2(P) ;TARGET
MOVEI TEMP,PITTYP ;SPECIAL CODE
GLOB <
CAIL C,GBRK ;IS IT GLOBAL???
JRST [
TERPRI <DON'T BIND PROCEDURES TO GLOBAL ITEMS>
CAI C,
ERR <ITEM NUMBER>,6
]
>;GLOB
MOVE USER,GOGTAB
DPB TEMP,INFOTAB(USER) ;PUT IN NEW DATUM TYPE
MOVEM LPSA,@DATAB(USER) ;SET DATUM
SUB P,[XWD 3,3]
JRST @3(P) ;RETURN
PITDGT: ;PROCEDURE TO GET PIT DATUM
MOVE LPSA,GOGTAB
GLOB <
CAIL C,GBRK ;
MOVE LPSA,GLUSER
>;GLOB
LDB B,INFOTAB(LPSA)
CAIE B,PITTYP ;IS IT A PROCEDURE ITEM???
JRST [ CAI C,
ERR <NOT A PROCEDURE ITEM >,6]
GLOB <
CAIL C,GBRK
ERR <DRYROT AT PITDGT>
>;GLOB
MOVE LPSA,@DATAB(LPSA) ;FETCH DATUM
POPJ P,
DSCR PITDTM
CAL PUSH P,PIT NO
PUSHJ P,PITDTM
DES SETS THE TOP OT THE STACK TO THE DATUM OF THE PROCEDURE ITEM
⊗
HERE(PITDTM)
MOVE C,-1(P) ;PICK UP ITEM NO
PUSHJ P,PITDGT ;GET ITS DATUM
MOVEM LPSA,-1(P) ;SET IT DOWN INTO THE STACK
POPJ P,
DSCR APPLY
CAL
PUSH P,[xwd context,pda]
PUSH P,ARGLIS
PUSHJ P,APPLY
DES
APPLY is the interpretive caller. Essentially, it uses the items
in ARGLIS to build a procedure call on the procedure named by the pda.
If context=0, then the procedure is just called in the normal manner.
If context is not zero, then APPLY will build a MSCP, using this value
as the static link, and will jrst to the instruction after the mscp.
⊗
HERE(APPL$Y)
APPLY ;A FAKED UP PD SO CAN SPROUT APPLY
;NOTE HERE THAT FOR UP WILL HAVE TO GO THROUGH 1 MORE
;LEVEL OF INDIRECTION
HERE(APPLY)
MOVE PDA,-2(P)
MOVE NPW,PD.NPW(PDA) ;THE STACK DISPLACEMENTS
HRRZ FPTR,PD.DLW(PDA) ;POINT AT FORMALS
NOGLOB <
MOVE USER,GOGTAB ;
>;NOGLOB
SKIPN APTR,-1(P) ;ARG LIST
JUMPN FPTR,NEACTS ;NULL ACTS,NON NULL FRMS
NXTP: SOJLE NPW,ARGSON ;HAD ENOUGH?
HLRZ FRM,(FPTR) ;NEXT FORMAL TYPE
HRRZ APTR,(APTR) ;LOOK AT NEXT ACTUAL
JUMPE APTR,NEACTS ;DONT HAVE ONE
HLRZ C,(APTR) ;THE ITEM
GLOB <
MOVE USER,GOGTAB ;
CAIL C,GBRK ;GLOBAL ??
MOVE USER,GLUSER ;
>;NOGLOB
LDB A,INFOTAB(USER) ;GET TYPE
CAIE A,RFITYP ;REF ITEM?
JRST [ PRINT <APPLY -- NON REFERENCE ITEM USED IN ACT PARAM LIST>
JRST BARG1
]
MOVE A,@DATAB(USER) ;GET THE DATUM
TRNE FRM,ITEMB ;FORMAL AN ITEM?
JRST FITEM ;YES
TLNE A,ITEMB ;ACTUAL AN ITEMVAR TYPE THING?
JRST BFACT ;LOSE ON CORRESP
MOVE B,A ;CHECK 6 BIT TYPE CORRESP
TLC B,(FRM) ;
TLNE B,MSK6BT ;TEST 6 BIT MASK
JRST BFACT ;MAY LATER CONSIDER COERCING
TRNE FRM,REFB ;
JRST FRMREF ;FORMAL IS A REF
TLC A,STTYPE ;STRING ?
TLNN A,MSK6BT ;WELL?
JRST STVPSH ;YOU BETCHA
PUSH P,@A ;PUSH THE VALUE OF THE ARG
AOJA FPTR,NXTP ;GO GET NEXT
STVPSH: PUSH SP,-1(A) ;PUSH A STRING
PUSH SP,(A) ;
ADD NPW,[XWD -2,1] ;FIX FOR THE SOJ AT NXTP
AOJA FPTR,NXTP
FRMREF: MOVEI A,@A ;THE ADDRESS
PUSH P,A ;THE REF
AOJA FPTR,NXTP ;NEXT
FITEM: TLNN A,ITEMB ;IS ACTUAL AN ITEM TOO
JRST BFACT ;YOU LOSE!
MOVE B,A ;GET ACTUAL BITS
TLC B,(FRM) ;6 BIT TYPES
TRNN FRM,MSKUNT ;FORMAL HAS 6 BIT TYPE?
JRST OK6BT ;NO
TLNE B,MSK6BT ;WIN?
JRST BFACT ;NO
OK6BT: TLNE B,ARY2B ;THE ARY2 BIT OK?
JRST BFACT ;NO
TLNE A,BINDB ;BINDING ACTUAL?
JRST BNDACT ;YES
TLNE A,QUESB ;? ACTUAL?
JRST QUEACT ;YES
;;#OL# WAS MAKING WRONG TEST ↓↓
TRNE FRM,REFB ;FORMAL REF?
JRST FRMREF ;YES
PUSH P,@A ;PUSH THE ITEM
AOJA FPTR,NXTP ;FETCH NEXT
BNDACT: TRNN FRM,QUESB ;FORMAL BETTER BE ?
JRST BFACT
PSHBRF: MOVEI A,@A
TLO A,20 ;TURN ON INDIR BIT
PUSH P,A ; @ REF
AOJA FPTR,NXTP ; GO DO NEXT
QUEACT: TRNN FRM,QUESB ;BETTER BE ?
JRST BFACT
MOVE B,@A ;GET THE VALUE NOW
CAIN B,UNBND ;HAVE A BINDING?
JRST PSHBRF ;NO
PUSH P,B ;YES
AOJA FPTR,NXTP ;
BFACT: PRINT <BAD CORRESPONDENCE BETWEEN ACTUAL & FORMAL PARAMETER TYPE>
BARG1: JSP TAC1,PRTARG ;
JSP TAC1,PITERR
JSP TAC1,PSPFIX ;FIX P & SP
JRST CRET ;EXIT FROM IT ALL
PRTARG: MOVEI FLAG,1(FPTR) ;FORMAL POINTER
SUB FLAG,PD.DLW(PDA) ;ORIGIN
HRRZ FLAG,FLAG ;GET THE RH OF IT
TERPRI
PRINT <ARGUMENT NUMBER >
DECPNT FLAG
TERPRI
JRST (TAC1) ;RETURN
PSPFIX: MOVE A,PD.NPW(PDA)
SUB A,NPW ;
SUBI P,(A) ;FIXUP RIGHT
HRLZ FLAG,A ;
ADD P,FLAG ;FIX LEFT
MOVS A,A
SUBI SP,(A) ;
HRLZ FLAG,A
ADD SP,FLAG ;FIX SP
MOVEI A,0
JRST (TAC1) ;RETURN
NEACTS: TERPRI
PRINT <APPLY--NOT ENOUGH ACTUAL PARAMETERS SUPPLIED >
JRST BARG1
ARGSON: TLNN PDA,-1 ;WERE WE GIVEN A CONTEXT
JRST CAL1 ;NO
PUSH P,[CRET] ;PUSH RETURN ADDRESS
PUSH P,RF
HRRZ A,PD.PPD(PDA) ;PARENTS PDA
MOVS B,PDA ;PDA,,STATIC LINK
HLRZ FRM,1(B) ;PDA OF DADDY???
CAME FRM,A ;????
JRST [
PRINT <CONTEXT WRONG OR CLOBBERED IN INTERP CALL>
JSP TAC1,PITERR
JSP PSPFIX
JRST CRET
]
PUSH P,B ;STATIC LINK
PUSH P,SP ;
HLRZ A,PD.PPD(PDA) ;WORD AFTER MKSEMT
JRST (A) ;GO THERE
CAL1: HRRZ A,PD.(PDA) ;ENTRY ADDRESS
PUSHJ P,(A) ;CALL IT
CRET: MOVE PDA,-2(P) ;HERE ON RETURN
MOVE FRM,PD.PDB(PDA) ;PROC type
TLC FRM,STTYPE ;SIMPLE STRING?
TLNN FRM,MSK6BT!ITEMB ;WELL?
SUB SP,[XWD 2,2] ;POP SP STACK
SKIPGE B,-1(P) ;GET THE LIST
PUSHJ P,RECBQQ ;ARGL WAS TEMP, RELEASE IT
SUB P,[XWD 3,3]
JRST @3(P) ;RETURN
PITERR: TERPRI
PRINT <PROCEDURE IS >
TERPRI
PUSHJ P,PRPID
ERR <IF YOU CONTINUE, THE PROCEDURE WILL NOT BE CALLED >,1
JRST (TAC1)
PRPID: PUSH P,A
PUSH P,B
PUSH P,C
HRRZ B,PD.ID1(PDA)
MOVE A,PD.ID2(PDA)
SOJL B,.+4
ILDB C,A
TTCALL 1,C
JRST .-3
POP P,C
POP P,B
POP P,A
POPJ P,
;;#OP# MAKE SURE A GETS SAVED
RECBQQ: EXCH A,B
PUSH P,B
PUSHJ P,RECQQ
POP P,A
POPJ P,
;;#OP#
BEND PITS
ENDCOM(PIT)
BEND GOGOL
INTERNAL ..PAT.
..PAT.:
PATCH: BLOCK 50