perm filename SAIARY.FAI[S,AIL] blob
sn#191933 filedate 1975-12-15 generic text, type T, neo UTF8
SEARCH HDRFIL
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)
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:
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.
HERE(LRMAK)
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
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
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
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
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
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
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
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
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
CAIN PDA,0 ;IS THIS THE BITTER END
ERR <GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
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
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
MOVE EN,(SIN) ;TYPE CODE
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
AOJA SIN,PARLP ;IF NOT VALUE SET, NO PROBLEMS
MOVEI EN,(C) ;EN←← PTR TO SET
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
JRST PLOOP ;
BEND STKUWD
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]
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
HERE (ARRBLT)
BEGIN ARRBLT
SOSGE LPSA,-1(P) ;GET LENGTH, SUBTRACT 1
JRST BLTRET ;LEQ 0, DONT BLT
HRRZ TEMP,-3(P)
HRL TEMP,-2(P)
ADDI LPSA,(TEMP)
BLT TEMP,(LPSA)
BLTRET: SUB P,X44
JRST @4(P)
BEND ARRBLT
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
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
SOJLE USER,DONEIT ;CHECK ONE WORD ARRAYS
ADDI TEMP,(USER) ;NUMBER OF WORDS TO MOVE IN BLT
BLT LPSA,(TEMP) ;DO A BLT
DONEIT: SUB P,X33
JRST @3(P) ;RETURN
BEND ARRCLR
ENDCOM(ARY)
END