perm filename ARYSER.OLD[S,AIL] blob
sn#178606 filedate 1975-10-27 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00008 PAGES VERSION 17-1(22)
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 HISTORY
C00005 00003 Array Stuff
C00012 00004 bexit & stkuwd
C00022 00005 array info & the like
C00027 00006 the procedure item routines
C00032 00007
C00041 00008
C00045 ENDMK
C⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000026 ⊗;
COMMENT ⊗
VERSION 17-1(22) 4-5-75 BY JFR ALLOW FOR DEFAULT ARGS IN APPLY P.7
VERSION 17-1(21) 11-30-74 BY RHT BUG #TS# ARRCLR WAS LOSING FOR 1 WORD ARRAYS
VERSION 17-1(20) 9-27-74 BY JFR INSTALL BAIL (MODIFY APPLY)
VERSION 17-1(19) 6-6-74 BY RHT BUG #SO# CLOBBERING B IN PARLP
VERSION 17-1(18) 5-27-74 BY RHT ADD FACILITY FOR RECORD ARRAYS IN BEXIT
VERSION 17-1(17) 5-19-74
VERSION 17-1(16) 4-14-74 BY RHT %BI% ADD RECORDS TO BEXIT
VERSION 17-1(15) 4-14-74
VERSION 17-1(14) 3-6-74 BY RHT ADD LEAP TO EXTERNS FOR SAIPIT
VERSION 17-1(13) 2-24-74 BY RHT FEAT %BH% -- TEMP REF ITEMS
VERSION 17-1(12) 2-3-74 BY RHT BUG #QZ# APPLY TESTING WRONG FIELD FOR STRING VAL PARAM
VERSION 17-1(11) 1-29-74 BY RHT BUG #QW# APPLY TOO TOUGH ON UNTYP ITEMVAR ACTUALS
VERSION 17-1(10) 1-28-74 BY RHT BUG #QU# TYPO IN APPLY
VERSION 17-1(9) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(8) 12-4-73 BY RHT MAKE ARRCL HAVE A DEFAULT VALUE TO STORE
VERSION 17-1(7) 12-2-73 BY RLS EDIT
VERSION 17-1(6) 12-2-73 BY RLS EDIT
VERSION 17-1(5) 12-1-73 BY RLS BUG #PL# DONT BLT IF LENGTH LEQ 0; PLUS ADD ARRCLR FUNCTION
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,ARRCLR>>
,<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) ; PTR TO 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 gtr 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 PTR TO 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 PNT TO NEXT WORD INTO TABLE, A=COUNT OF DIMENSIONS LEFT,
C=ACCUMULATING TOTAL SIZES (AGAIN)
B PNTS AT 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) ; PTR TO 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 ;PTR TO 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
RDREF ;11 RECORD
RRARY ;12 RECORD ARRAY
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,
RGC <
RRARY: ;RECORD ARRAYS ARENT SPECIAL IF HAVE GC
>;RGC
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,
REC <
RDREF:
NORGC <
SKIPN A,@EN ;GONE ALREADY
POPJ P,
SOSLE -1(A) ;REF COUNT LOSES ONE
JRST .+3 ;DONE
AOS -1(A) ;PUT IT BACK SO NEXT GUY CAN DO SAME
RECUUO 0,@EN ;DEREFERENCE LIKE SO
SETZM @EN ;ZERO OUT
POPJ P, ;RETURN
RRARY: SKIPN A,@EN ;RECORD ARRAY STILL THERE??
POPJ P, ;NOPE
SETZM @EN ;WE ARE KILLING IT
PUSH P,(P) ;RETN ADRS
MOVEM A,-1(P) ;FOR EVENTUAL CALL TO ARYEL
HRLZI EN,C ;
HRRI EN,-1(A) ;EN = POINTER AT NEXT
HRRZ C,-1(A) ;C = COUNT
JUMPE C,ARYEL ;ALL DONE
PUSHJ P,RDREF ;DEREFERENCE ONE
SOJG C,.-1 ;ITERATE UNTIL DONE
JRST ARYEL
>;NORGC
RGC <
SETZM @EN ;SO GC DOESN'T FIND IT
POPJ P,
>;RGC
>;REC
NOREC <
RRARY:
RDREF: JRST DRYROT
>;NOREC
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← PTR 1 BEFORE 1'ST ARITH PARM
PARLP: SOJLE B,ADJSKS ;COUNT DOWN # ARGS
AOS C ;POINT AT NEXT
;;#SO# RHT,RFS THIS PIECE OF CODE WAS STILL USING B
MOVE EN,(SIN) ;TYPE CODE
;;#NF# RHT 24 JULY 73 THIS PIECE OF CODE WAS STILL USING TBITS
TLC EN,SETYPE⊗5 ;VALUE SET MUST BE RELEASED
TLNN EN,REFB!ITEMB!PROCB ;THESE ARE NOT RELEASED
TLNE EN,MSK6BT ;CHECK THE SET CODE
;;#NF#
;;#SO#
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
;;% % MAKE SET RELEASE SAFE FOR THIS LOOP (MERE PARANOIA)
PUSH P,SIN
PUSH P,C
PUSH P,B
PUSHJ P,@LVIDAC+3 ;CALL SET RELEASER
POP P,B
POP P,C
POP P,SIN
;;% %
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
;;#PL 12-1-73 RLS (1 OF 2) DONT BLT IF COUNT IS LEQ 0
SOSGE LPSA,-1(P) ;GET LENGTH, SUBTRACT 1
JRST BLTRET ;LEQ 0, DONT BLT
;;#PL
HRRZ TEMP,-3(P)
HRL TEMP,-2(P)
ADDI LPSA,(TEMP)
BLT TEMP,(LPSA)
;;#PL 12-1-73 RLS (2 OF 2) DONT BLT IF COUNT IS LEQ 0: LABEL NEXT LINE
BLTRET: 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
DSCR ARRCLR(ARRAY,VAL(0))
DES FILLS UP ARRAY WITH VAL
CAL SAIL
⊗
HERE(ARRCLR)
BEGIN ARRCLR
MOVE USER,-1(P) ;VALUE TO PUT
MOVE TEMP,-2(P) ;GET ADDRESS OF ARRAY
SKIPL -2(TEMP) ;CHECK STRING ARRAY
JRST NOSACL
SUBI TEMP,1 ;A STRING ARRAY STARTS EARLIER
CAIE USER,0 ;
ERR <YOU CANNOT CLEAR STRING ARRAYS TO OTHER THAN NULL>;
NOSACL: HRLI LPSA,(TEMP) ;PREPARE FOR BLT
HRRI LPSA,1(TEMP)
MOVEM USER,(TEMP)
HRRZ USER,-1(TEMP) ;GET NUMBER OF WORDS IN ARRAY
;;#TS# CHECK FOR ONE WORD ARRAYS
SOJLE USER,DONEIT ;CHECK ONE WORD ARRAYS
ADDI TEMP,(USER) ;NUMBER OF WORDS TO MOVE IN BLT
;;#TS# ↑
BLT LPSA,(TEMP) ;DO A BLT
DONEIT: SUB P,X33
JRST @3(P) ;RETURN
BEND ARRCLR
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,ACF,PLISTE>
,,<DUMMY PROCESS VARIABLES>)
↑↑SPRPDA:
↑↑RESUME:
↑↑TERMIN:
↑↑SPROUT:
↑↑DADDY:
ERR <DRYROT-LIBRARY>
↑↑CURSCB ←← 0;
↑↑ACF←←12+3;
↑↑PLISTE ←← 0;
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,LEAP>
,<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
;;%##% ! half kill the symbol
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
;;%CV% JFR 8-22-75 Try to trap problems before they get too far in overlays
IFNDEF JOBOVL,<JOBOVL←←131>
SKIPN TEMP,JOBOVL
JRST .+3
CAMGE TEMP,(LPSA) ;IS ENTRY ADDR GTR THAN CONTROL SECTION ADDRESS OF ROOT?
ERR <PITBND: PROC ADDR GTR (JOBOVL)>,1
;;%CV% ↑
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
BAIL<
PUSH P,location to return string result
PUSH P,location to return non-string result
the context below will be -1 and is a special flag value,
not really the static link
>;BAIL
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)
BAIL<
SETZ TAC2, ;ASSUME NOT BAIL APPLY
TLC PDA,-1
TLCN PDA,-1 ;BAIL APPLY?
SETO TAC2, ;YES
>;BAIL
MOVE NPW,PD.NPW(PDA) ;THE STACK DISPLACEMENTS
HRRZ FPTR,PD.DLW(PDA) ;POINT AT FORMALS
NOGLOB <
MOVE USER,GOGTAB ;
>;NOGLOB
BAIL<
JUMPE TAC2,NBAP01 ;IF NOT BAIL APPLY
MOVE APTR,-1(P) ;ARLIST LOCATION-1
JRST NXTP
NBAP01:
>;BAIL
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
BAIL<
JUMPE TAC2,NBAP02 ;IF NOT BAIL APPLY
AOS APTR ;POINT TO NEXT REFITEM DATUM
SKIPN A,(APTR) ;SKIP IF NOT END OF LIST
JRST NEACTS
JRST BAPCHK ;GO CHECK TYPES
NBAP02:
>;BAIL
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
BAIL<
BAPCHK:
>;BAIL
DEFACT:
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
;;#QZ# ! 2-3-74 USED NOT TO BE SHIFTED RHT
TLC A,STTYPE⊗5 ;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
;;#QW# 1 OF 2 ALLOW MORE LENIENCY HERE
TLNN A,MSKUNT ;DOES ACT HAVE 6 BIT TYPE SPEC
JRST AUTITM ;NOPE
;;#QW#
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 ;
;;#QW# 1-29-74 RHT (2 OF 2)
AUTITM: ;COME HERE WHEN FORMAL SPEC & ACT UNSPEC
TLNE A,ARY2B ;ACT AN ARY2 THING?
JRST OK6BT ;YES, PRETEND THAT 6 BIT TYPES ARE OK
TRNE FRM,REFB!BINDB ;FORMAL REF OR BIND ?
JRST OK6BT ;IF SO, A REGULAR WIN
SKIPN C,@A ;GET ULT VALUE TO SEE IF OK
JRST OK6BT ;LET ANY THROUGH TOO
CAIN C,UNBND ;UNBOUND ? WILL ACT LIKE BIND
TRNN FRM,QUESB ;
SKIPA USER,GOGTAB ;NOT THIS BAD CASE
JRST OK6BT ;WAS UNBND ? IVAR
GLOB <
CAIL C,GBRK
MOVEI USER,GLUSER
>;GLOB
LDB C,INFOTAB(USER) ;GET ACTUAL ITEM TYPE
LSH C,5 ;TO LINE THINGS UP FOR THE TRC
TRC C,(FRM) ;CHECK 6 BIT TYPE OF THIS ACTUAL VAL ITEM
TRNN C,MSK6BT ;SEE IF WIN
JRST OK6BT ;WELL, WE HAVE REALLY WON
;ELSE FALL INTO BFACT CODE
;;#QW#
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:
;;%##% JFR 4-4-75 ALLOW FOR DEFAULT ARGUMENTS
TRNN FRM,400000 ;IS IT DEFAULTABLE?
JRST NEACT1 ;NO
BAIL< JUMPE TAC2,.+2 ;SKIP IF NOT BAIL APPLY
SOS APTR ;FIX FOR NEXT TIME
>;BAIL
MOVE A,(FPTR) ;REFITEM FOR DEFAULT VALUE
JRST DEFACT ;CONTINUE
NEACT1:
;;%##% ↑
TERPRI
PRINT <APPLY--NOT ENOUGH ACTUAL PARAMETERS SUPPLIED >
JRST BARG1
ARGSON:
BAIL<
JUMPN TAC2,CAL1 ;SKIP SPECIAL CONTEXT FOR BAIL
>;BAIL
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 TAC1,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
BAIL<
SETZ TAC2, ;ASSUME NOT BAIL APPLY
TLC PDA,-1
TLCN PDA,-1 ;BAIL APPLY?
SETO TAC2, ;YES
>;BAIL
MOVE FRM,PD.PDB(PDA) ;PROC type
BAIL<
JUMPE TAC2,NBAP03 ;IF NOT BAIL APPLY
TLC FRM,STTYPE⊗5 ;SIMPLE STRING?
TLNE FRM,MSK6BT!ITEMB ;WELL?
JRST BAPRNS ;NO
MOVE A,-4(P) ;YES. ADDRESS OF STRING DESCR
POP SP,(A) ;FIRST WORD
POP SP,-1(A) ;SECOND WORD
JRST .+2
BAPRNS: MOVEM A,@-3(P) ;RETURN NON-STRING RESULT
SUB P,[XWD 5,5]
JRST @5(P) ;RETURN
NBAP03:
>;BAIL
;;#QU# ! type forgot the lsh 5 RHT 1-28-74
TLC FRM,STTYPE⊗5 ;SIMPLE STRING?
TLNN FRM,MSK6BT!ITEMB ;WELL?
SUB SP,[XWD 2,2] ;POP SP STACK
;;%BH%
SKIPN B,-1(P) ;GET THE LIST
JRST TMIDON ;NO LIST
TMIKIL:
HRRZ B,(B) ;STEP THE LIST
JUMPE B,TMIDON ;A ZERO MARKS THE END
HLRZ C,(B) ;GET ITEM NUMBER
SKIPL @DATM ;AT THIS POINT, KNOW IS REFITEM
JRST TMIKIL ; THE SIGN BIT IS TMPB (GEQ 0 MEANS PERM)
;IF GET HERE C IS A TEMP ITEM
PUSH P,B ;SAVE LIST PTR
PUSH P,C ;THE ITEM NUMBER
MOVEI 5,43 ;DELETE CODE
PUSHJ P,LEAP ;UGH! WHAT A TERRIBLE WAY TO DO THINGS
POP P,B
JRST TMIKIL ;CONTINUE
TMIDON:
;;%BH%
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