perm filename ARRAY[S,AIL]13 blob
sn#086456 filedate 1974-02-13 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00016 PAGES VERSION 17-1(9)
RECORD PAGE DESCRIPTION
00001 00001
00003 00002 HISTORY
00007 00003 Array Semblk, Routine Descriptions
00015 00004 Array Routine Data
00019 00005 Array Declaration Routines -- STARY, ENTARY
00022 00006 ARRSUB
00025 00007 ARRDEC
00031 00008 OWNARR: MOVE ARRBIT,ARYLST #ARRAYS WITH THESE DIMENSIONS
00037 00009
00041 00010 ADCND:
00045 00011 DSCR LDYBEG, LDYREP, LDYNO
00050 00012 DSCR ARYIDX, ARRSBY, ARRSB1
00052 00013 FIRST PART SETS UP ARRBIT TO INDICATE EXACT CONDITIONS
00058 00014 CHECK UPPER BOUNDS
00063 00015 DSCR SUBSCR
00069 00016 DSCR DOSFTY
00070 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000011 ⊗;
COMMENT ⊗
VERSION 17-1(9) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT A STRING
VERSION 17-1(8) 12-10-73 BY JRL ON BUG PP ONLY GIVE ERROR IF AN OWN ARRAY
VERSION 17-1(7) 12-7-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS (WHERE POSSIBLE)
VERSION 17-1(6) 12-5-73 BY JRL BUG #PP# FIX NO GOOD, GIVE ERROR MESSAGE.
VERSION 17-1(5) 12-5-73 BY JRL BUG #PP# OWN ARRAYS CAUSE PROBLEMS WITH HISEG COMPILATIONS
VERSION 17-1(4) 11-26-73 BY RHT BUG #PE# LDYTOT WAS BEING CLOBBERED IN LDYOUT
VERSION 17-1(3) 11-18-73 BY JRL REMOVE FINAL REFERENCE TO PATSW
VERSION 17-1(2) 9-14-73 BY JRL BUG #OD# SEND TYPE BITS TO ARRAY ITEM ALLOCATOR
VERSION 17-1(1) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(24) 5-31-73 BY JRL BUG #MO# ANOTHER LDYFLG BUG
VERSION 16-2(23) 5-31-73
VERSION 16-2(22) 5-14-73 BY RHT BUG #MI# MUST ALWAYS ZERO LDYFLG
VERSION 16-2(21) 5-10-73 BY RHT BUG #MG# LDYFLG HACK WAS ABUSED
VERSION 16-2(20) 5-4-73 BY RHT ARRANGE NOT TO ZERO OWN ARRAYS
VERSION 16-2(19) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(18) 2-23-73 BY JRL BUG #LO# GLOBAL ARRAY ITEMVAR ARRAY NOT GLOBAL ARRAY ITEM
VERSION 16-2(17) 2-9-73
VERSION 16-2(16) 1-8-73
VERSION 16-2(15) 1-8-73 BY JRL BUG #KU# DYNAMICALLY CREATE ARRAY ITEMS
VERSION 16-2(14) 1-8-73
VERSION 16-2(13) 12-6-72 BY DCS BUG #KR# SOME ITEMVARS JUST DON'T HAVE NAMES
VERSION 16-2(12) 11-24-72 BY JRL FIX POTENTIAL GLOBAL ITEM ARRAY BUG
VERSION 16-2(11) 11-6-72 BY JRL ALLOW PRELOADED ITEMVAR ARRAYS
VERSION 16-2(10) 8-29-72 BY KVL FIX SMALL BUG IN LEAP ARRAYS - ARRDEC
VERSION 16-2(9) 8-9-72 BY JRL NEW "GLOBAL" ARRAY HACK
VERSION 16-2(8) 7-18-72 BY DCS BUG #IQ# MAKE JUMP TO ARRAY DECL HAPPEN BEFORE BOUNDS CHECK
VERSION 16-2(7) 6-6-72 BY DCS BUG #HN# ALLOCATE 0 FOR ALL DYNAMIC ARRAYS
VERSION 16-2(6) 5-2-72 BY JRL CHANGE PARAM TO LPCALL(ITMRY)
VERSION 15-2(5) 4-29-72 BY RHT PUT IN MAKE!SAFE & MAKE!UNSAFE FEATURE
VERSION 15-2(4) 2-7-72 BY DCS BUG #GP# WARN IF ATTEMPT TO PRELOAD DYNAMIC ARRAY
VERSION 15-2(3) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(2) 1-10-72 BY DCS BUG #FP# FIX NEGAT BUG ON INDEX FETCH
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
SUBTTL Array Semblk, Routine Descriptions
LSTON (ARRAY)
BEGIN ARRAY
Comment ⊗ (a la D. Poole)
Here are the GRAND and GLORIOUS routines for talking about arrays:
An array descriptor has the form:
ARR: ptr to BNDBLK,, ptr to next bucket element
<$PNAME,BITS of various varieties>
TOTDSP: total displacement(see below),,fixup for array variable
NUMDIM: #dims,,ACNO of array address
ARLOC: addr of first data word, if known(lh -1 for STRING)
$VAL2: global # or item # const semantics if LPARRAY
<ring pointers>
BNDBLK is the bounds block for this array, described below.
ARLOC(rh) has the address of the first data word of compiled-in
arrays (OWN on in TBITS) -- top level arrays. (lh as above)
TOTDSP (lh) has [0,0,0] location for array, if known
When a subscript calculation needs to be made, a block of the
following form is created:
IDXBLK: ptr partial-calculations,,ptr array descriptor
DIMPRC: #dimensions processed so far
BNDPNT: BNDPTR (see below)
NUMDIM: # dimensions
<others 0>
Partial-calcs is a TEMP block describing partial index
calculations to date.
BNDBLK is a block containing information about any constant array
bounds, if the dimensionality of the array is leq 5.
BNDPTR is a pointer to the set of 2 words in BNDBLK describing
the current index:
bits,,upper bound for this dimension
lower bound,,PRODUCT[i←(current dim+1) to n](size(dimension i)) (mult factor)
bits: 100000 -- NOMUL -- when on, can not do IMULI for size calc
40000 -- MULMUL -- ¬NOMUL
200 -- LOWFIX -- lower bound fixed
40 -- LOWVAR -- ¬LOWFIX
20 -- BOTFIX -- lower and upper fixed
4 -- SOMVAR -- ¬BOTFIX
The array routines are divided into two sections:
two routines called to declare
arrays (ARRSUB and ARRDEC), and three called to calculate
a subscript when a subscripted variable occurs in an expression
or assignment statement (ARYIDX, ARRSBY, and SUBSCR).
The syntactic contexts for these routines are:
ARDEC E : E SG drarrow ARDEC ARRSUB
ARDEC E : E ] drarrow ARDEC ARRDEC
@IARY [ drarrow ARID ARYIDX
@ARY E , drarrow @ARY ARRSBY
ARID E ] drarrow ] ARRSB1 SUBSCR
Instructions of the following form will be emitted by ARRSUB for each
index. ARRX is an AC containing a pointer to the first
data word of the array (dimension info below it in core).
AC is the AC containing current index calculations. The
conditions under which each kind of instruction is issued
is given to its right. Instructions not separated by
blank lines are alternatives. There is for each
kind of instr. at least one circumstance under which
no instruction at all will be issued:
MOVE AC,INDEX ;index not in AC
SKIPL AC ;¬SAFE and ¬BOTFIX and (¬LSTDX or ¬LOWFIX)
CAIL AC,lowbnd ;¬SAFE and LOWFIX and ¬BOTFIX and ¬LSTDX
CAMLE AC,-1-3*dimno+1(ARRX) ;¬SAFE and ¬BOTFIX
CAILE AC,totsiz ;¬SAFE and BOTFIX
ARERR dimno,"array name" ;¬SAFE
IMUL AC,-1-3*dimno+2(ARRX) ;¬LSTDX and ¬NOMUL
IMULI AC,multiplier(dimno) ;¬LSTDX and NOMUL
ADD AC,old calculation ;not the first index calc
There is also the feature of preloading the array with good things.
For this operation, the routines LDYBEG, LDYREP, and LDYNO are
called to record on a generalized stack the arguments to load into
the array.
⊗
TOTDSP←←$ADR ;TOTAL DISPLACEMENT (CONSTANT) FOR THIS ARRAY
ARLOC ←←$VAL ;LOCATION OF ARRAY
BNDPNT←←$DATA2 ;PTR TO CURRENT ENTRY IN BNDBLK (FOUND IN IDXBLK)
DIMPRC←←$DATA ;#DIMENSIONS PROCESSED TO DATE
NUMDIM←←$ACNO ;NUMBER OF DIMENSIONS FOR THIS ARRAY
ARRBIT←←TBITS2 ;BITS AND THINGS ABOUT THIS INDEX
TBLIDX←←SBITS2 ;OFTEN HOLDS INDICES (IN ARRSBY)
; BITS USED IN ARRAY ROUTINES
; * INDICATES SUPPLIED BY BNDBLK
; ⊗ INDICATES USED IN ARRSBY
; + INDICATES USED IN SBSCRP
↑ARRBTS:
BIT(SPARE,400000)
BIT(DATMR,200000) ;IF ARRAY IS DATUM OF SOME ITEM ⊗
BIT(NOMUL,100000) ;IF IMULI CANNOT BE DONE THIS INDEX ⊗*
BIT(MULMUL,40000) ;¬NOMUL ⊗*
BIT(ONED,20000) ;ONE DIMENSIONAL ARRAY ⊗
BIT(MANYD,10000) ;¬ONED ⊗
BIT(LSTIDX,4000) ;PROCESSING LAST INDEX ⊗
BIT(NOTLST,2000) ;¬LSTIDX ⊗
BIT(IDXCON,1000) ;THIS INDEX IS A CONSTANT ⊗
BIT(IDXVAR,400) ;¬IDXCON ⊗
BIT(LOWFIX,200) ;LOWER BOUND IS CONSTANT ⊗*
;OWN ←← 100 ;BUILT-IN ARRAY (FROM TBITS) +
BIT(GOTARR,100) ;HAD TO GET ARRAY DESCR. INTO AN AC ⊗
BIT(LOWVAR,40) ;¬LOWFIX ⊗*
;KNOWALL←← 20 ;KNOW ENTIRE OFFSET (FROM SBITS) +
BIT(SPARE,20)
BIT(BOTFIX,10) ;LOWER AND UPPER BOUNDS CONSTANT ⊗*
NOTCLC←←10 ;NO PARTIAL CALCS WHEN SBSCRP CALLED +
BIT(SOMVAR,4) ;¬BOTFIX ⊗*
SOMCLC←←4 ;¬NOTCLC +
BIT(DANGAR,2) ;NON-SAFE ARRAY (FROM TBITS) ⊗
BIT(SAFEAR,1) ;¬DANGAR ⊗
IFN FTDEBUG,<BLOCK =18>
SUBTTL Array Routine Data
ZERODATA (ARRAY VARIABLES)
;ABLKPT -- Indirect ptr for ARRSUB for indexing a BNDBLK
?ABLKPT: 0
;ARRDSP -- used to collect total constant displacement (from
; [0,0,0] loc) during array declarations
?ARRDSP: 0
;ARRSIZ -- collects total array size during declaration
; (only used if all bounds constant, and Array is OWN)
?ARRSIZ: 0
COMMENT ⊗
ARYBITS -- STARY puts the contents of BITS here when the ARRAY
attribute is seen during declaration. This is done because
many arrays may share the same declarations, and we want these
bits to remain safe over the entire process
⊗
↑↑ARYBITS: 0
;ARYBLK -- prototype BNDBLK for array. See ARRAY DSCRs for details
?ARYBLK: BLOCK =15
;ARYLST -- count of number of arrays with same dimensions, etc.
?ARYLST: 0
;ARYPDL -- QSTACK descriptor (QPDP) to hold Semantics of all
; Arrays with the same types and dimensions. Stored here until
; the dimensions are known and the arrays can be allocated.
?ARYPDL: 0
?BLKOK: 0 ;TEMP ARRAY VARIABLE
?CURENT: 0 ;REPEAT FACTOR DURING PRELOAD SPECS
?DIMNO: 0 ;COUNTS # DIMS DURING ARRAY DECLARATION
?LDYFLG: 0 ;ON DURING ARRAY ALLOC IF PRELOADED ARRAY
;;#MG# RHT 1 OF 3
; -1 IF REALLY PRELOADED 777777 IF MERELY
;OWN ARRAY.
;;#MG#
;LDYSTK -- QSTACK dscrptr. -- each word is [XWD rept,Semantics of const]
; for a PRELOAD value -- collected during PRELOAD spec, used when
; array is allocated
?LDYSTK: 0
;LDYTAK -- QSTACK dscrptr of first entry in LDYSTK Qstack. Used to
; remove elements in order of insertion (via QTAK).
?LDYTAK: 0
?LDYTOT: 0 ;TOTAL # WORDS IN PRELOAD SPEC
?LEFMRK: 0 ;STRING/ARITH DIFFERENTIATOR DURING DECL.
;NOMULT -- flag during declarations -- turned on if multiples
; may are no longer constant (must use dope vector for remaining
; dimensions)
?NOMULT: 0
?OWNWD: 0 ;TEMP DURING ARRAY DECLARATIONS
?SIZZ: 0 ;TEMP WHILE GENERATING ARRAY-INDEXING CODE
ENDDATA
SUBTTL Array Declaration Routines -- STARY, ENTARY
DSCR ARRAY DECLARATION CODE
DES Most Declaration routines are in GEN, but these were moved to
be close to their variables (OHHHHHHH).
ENTARY enters an Array name, saves its semantics in ARYPDL
STARY sets up array variables prior to dimension and size scanning
PRO ENTARY STARY
⊗
↑STARY: MOVE B,BITS ;CURRENT COLLECTION OF BITS.
TLO B,SBSCRP
↑↑HELSPC: SETZM OWNWD ;CLEAR TEMP ARRDEC CELLS
SETZM ARRSIZ
SETZM ARRDSP
SETZM SIZZ
SETZM BLKOK
SETZM ARYBLK
MOVE TEMP,[XWD ARYBLK,ARYBLK+1] ;CLEAR PROTOTYPE BNDBLK
BLT TEMP,ARYBLK+=10-1
TLNN FF,TOPLEV ;IF TOPLEV and ¬EXTERNAL,
JRST EXRAY
;; #KU# BY JRL (1-8-73) DON'T MAKE ARRAY ITEMS OWN BY DEFAULT
TDNN B,[XWD EXTRNL,GLOBL!ITEM] ;MARK ARRAY "OWN".
TLO B,OWN ; SO IT WILL BE COMPILED IN
EXRAY:
MOVEM B,ARYBITS ;KEEP THEM SAFE FROM CONSTANTS, ETC.
MOVEM B,BITS
POPJ P,
↑ENTARY: MOVE B,ARYBITS ;SAVED BITS
MOVEM B,BITS
;;#IQ#3! 7-18-72 DCS MOVED FROM ARRSUB TO HAPPEN BEFORE BOUNDS CALCS
TLNN B,OWN ;HOME ANY JUMP, IF DYNAMIC ARRAY
PUSHJ P,ENDJMP
JFCL ;SKIP-RETURNS UNIMPORTANT
PUSHJ P,ENTID
MOVE A,LPSA
QPUSH (ARYPDL) ;SAVE SEMANTICS FOR STARLP CODE
AOS ARYLST ;COUNT # ARRAYS WITH SAME DIMS
SETZM DIMNO ;NUMBER OF DIMENSIONS
POPJ P, ;GO AWAY
SUBTTL ARRSUB
DSCR ARRSUB, ARRDEC
PRO ARRSUB ARRDEC
DES ARRSUB collects bounds information -- runs once for each pair
ARRDEC issues declaration code for all arrays with same type and
bounds.
SEE Comments at beginning of ARRAY for details
⊗
↑ARRSUB:
AOS TEMP,DIMNO ;COUNT DIMENSIONS
CAILE TEMP,5 ;TOO MANY TO PLAY WITH BLOCK?
JRST TOMNY ; YES
LSH TEMP,1 ;*2 TO INDEX ARYBLK
ADDI TEMP,ARYBLK-1 ;2D WORD OF THIS ENTRY IN ARYBLK
MOVEM TEMP,ABLKPT ;STORE IN CORE
TOMNY: MOVE TBITS,ARYBITS ;BITS DESCRIBING ARRAY
TLNE TBITS,EXTRNL ;IF EXTERNAL, DON'T ALLOCATE
POPJ P,
MOVSI ARRBIT,SOMVAR!LOWVAR!MULMUL ;ASSUME NOT OWN ARRAY
TLNE TBITS,OWN ;TEST ASSUMPTION
; OWN (BUILT-IN) ARRAY
TLO ARRBIT,400000 ;INVALID ASSUMPTION
;;#IQ# 7-18-72 DCS ENDJMP CODE MOVED TO ENTARY
MOVE PNT,GENLEF+3 ;LOWER BOUND SEMANTICS
GENMOV (CONV,INSIST!GETD,INTEGR)
JUMPL ARRBIT,NOSTKL ;DON'T STACK IF TOP-LEVEL
GENMOV (STACK) ;STACK LOWER BOUND
NOSTKL: TLNN TBITS,CNST ;IF IT IS CONSTANT,
JRST NOLOCN
MOVE TEMP,$VAL(PNT) ;GET VALUE
MOVEM TEMP,@ABLKPT ; SAVE LOWER BOUND
TLC ARRBIT,LOWFIX!LOWVAR ; AND INDICATE FIXEDNESS
NOLOCN: MOVE PNT,GENLEF+1 ;UPPER BOUND SEMANTICS
GENMOV (CONV,INSIST!GETD,INTEGR)
JUMPL ARRBIT,NOSTKH ;NO STACKING ETC.
GENMOV (STACK)
NOSTKH: TLNE ARRBIT,LOWFIX ;DON'T GO FURTHER IF LOWBND VBL
TLNN TBITS,CNST ; OR UPPER VBL
JRST NOHICN
MOVE TEMP,$VAL(PNT) ;UPPER BOUND
SOS ABLKPT ;SAVE THIS TOO
HRRM TEMP,@ABLKPT ;SAVE IT
TLCA ARRBIT,BOTFIX!SOMVAR ;MARK BOTH FIXED
NOHICN: SOS ABLKPT
JUMPGE ARRBIT,OKFXD ;BE SURE ALL IS CONST IF
TLNN ARRBIT,BOTFIX ; TOPLEV
ERR <CONSTANT BOUNDS REQD FOR TOP-LEVEL ARRAY>,1
OKFXD: TLZ ARRBIT,400000
HLLM ARRBIT,@ABLKPT ;UPDATED BITS
POPJ P, ;THAT'S ALL
SUBTTL ARRDEC
↑ARRDEC:
; FIRST GET A DECENT ARYBLK, FULL OF GOOD THINGS
MOVE A,DIMNO ;#DIMENSIONS FOR THESE ARRAYS
CAIG A,5 ;IF > 5-DM FORGET THE REST OF THIS
JRST BECLEVER ;OTHERWISE PREPARE TO BE CLEVER
SETOM BLKOK ;CAN'T USE THE BLOCK
JRST MAKARY ;GO MAKE AN ARRAY
BECLEVER:
SETZM NOMULT ;WHEN ON, NUMUL GOES
; ON IN REMAINING BITS
LSH A,1 ;2*DIMNO FOR INDEXING TABLE
ADDI A,1 ;FIRST SOJE WILL HAVE NO EFFECT
MOVEI C,1 ;FIRST MULTIPLIER
MOVEI D,0 ;COLLECT TOTAL CONSTANT DISPLACMENT
MOVE TBITS,ARYBITS ;GET GOOD BITS
MOVSI B,BOTFIX ;MAKE TLNN TAKE FIRST TIME
; THIS LOOP CONDITIONS THE ENTRIES IN ARYBLK TO LOOK LIKE THE ABOVE
; COMMENTS SAID THEY WOULD LOOK -- COMPUTES THE MULTIPLIER VALUES, MAKES NOMUL
; BIT CORRECT IN EACH ENTRY. ALSO COLLECTS THE TOTAL CONSTANT DISPLACEMENT
; WHICH CAN BE USED TO MAKE ARRAY CALCULATIONS FASTER.
; IF "GOGOL", ALSO STACKS (ACTUALLY) THE BOUNDS FOR (ACTUAL) CALL ON ARMAK.
CLEVLUP:
SOJE A,MAKARY
TLNN B,BOTFIX ;WILL WE STILL BE ABLE TO USE
SETOM NOMULT ; CONSTANT MULTIPLIERS? -- NO
MOVE TEMP,ARYBLK-1(A) ;LOWBND
HRLM TEMP,ARYBLK-1(A) ;SAVE IN LH
HRRM C,ARYBLK-1(A) ;SAVE MULTIPLIER
HLLZ B,ARYBLK-2(A) ;BITS
TLNN B,LOWFIX ;IF LOWFIX,
JRST CHKMUL
IMUL TEMP,C ;COMPILE TOTAL DISPLACEMENT
SKIPN NOMULT ; (IF STILL COLLECTING IT)
ADD D,TEMP ; IN D
HRRE TEMP,ARYBLK-2(A) ;UPPER BOUND THIS DIM
TLNN B,BOTFIX ;IGNORE IF CAN'T USE
JRST CHKMUL
HLRE PNT,ARYBLK-1(A) ;LOWER BOUND
SUB TEMP,PNT ;-LOWER BOUND
ADDI TEMP,1 ; +1 IS TOTAL SIZE
SKIPGE TEMP
ERR. 1,[ASCIZ /UPPER BOUND < LOWER BOUND IN ARRAY DECLARATION/]
IMUL C,TEMP ;UPDATE MULTIPLIER
CHKMUL: SKIPE NOMULT
TLC B,NOMUL!MULMUL ;CAN'T USE CONST MULTS NO MORE
HLLM B,ARYBLK-2(A) ;STORE PERHAPS UPDATED BITS
SOJA A,CLEVLUP ;GO BE MORE CLEVER
MAKARY: TLNN B,LOWFIX ;CAN'T ASSUME KNOWALL IF HIGH-ORDER
SETOM NOMULT ;LOW BOUND NOT CONSTANT
SETZM LEFMRK ;WILL BE -1 FOR STRING, 0 ELSE
MOVE TBITS,ARYBITS ;DESCRIBE THESE ARRAYS
TRNN TBITS,STRING ;DOUBLE SIZES FOR STRING ARRAYS
JRST MKRY1
SETOM LEFMRK
LSH C,1
LSH D,1
MKRY1: MOVEM C,ARRSIZ ;SAVE TOTAL ARRAY SIZE
MOVEM D,ARRDSP ;AND TOTAL CONSTANT DISPLACMENT
TLNE TBITS,EXTRNL ;HANDLE EXTERNALS IN COMPLETELY
JRST EXARST ; DISJOINT FASHION
TLNE TBITS,OWN ;HANDLE OWN ARRAYS SOMEWHAT
JRST OWNARR ; DIFFERENTLY (DON'T PUT OUT CALLS)
; FINISH SETTING UP CALLING SEQUENCE FOR DYNAMIC ARRAYS
;;#GP# DCS 2-7-72 (1-2) WARNING ON ATTEMPT TO PRELOAD DYNAMIC ARRAY
SKIPE LDYFLG ;DON'T LET PRELOADS GO UNNOTED
ERR <DON'T PRELOAD DYNAMICALLY ALLOCATED ARRAYS>,1
;;#GP# (1)
MOVE A,DIMNO ;NUMBER OF DIMENSIONS.
HRL A,LEFMRK ;-1 FOR STRING, 0 OTHERWISE
PUSHJ P,CREINT ;MAKE AN INTEGER
GENMOV (STACK,0) ;STACK IT.
XPREP
MOVE SBITS2,DIMNO ;JUST A PLACE THAT WON'T CHANGE.
MOVE A,DIMNO
LSH A,1 ;MULTIPLY BY TWO
ADDI A,1 ;AND ACCOUNT FOR WORD WITH #OF DIMS.
MOVN TEMP,A ;ALSO RESTORE ADEPTH TO NORMAL
ADDM TEMP,ADEPTH
HRLS A ;AND COPY IN BOTH HALVES.
PUSHJ P,CREINT ;AND MAKE AN INTEGER OF IT.
MOVE PNT2,PNT ;SEMANTICS OF THE INTEGER.
MOVE ARRBIT,ARYLST ;#ARRAYS WITH THESE DIMENSIONS
SETZM OWNWD ;NOT OWN ARRAY
JRST STARLP ;GO ALLOCATE ARRAYS
OWNARR: MOVE ARRBIT,ARYLST ;#ARRAYS WITH THESE DIMENSIONS
SETOM OWNWD ;MARK OWN ARRAY
Comment ⊗ For each array, either issue call to set it up,
or assemble it in line ⊗
STARLP: QPOP (ARYPDL) ;RESCUE THE SEMANTICS FROM QSTACK
PUSH P,A ;SAVE SEMANTICS UNTIL LATER
SKIPE OWNWD ;DYNAMIC OR OWN?
JRST STOWN ; OWN
AG1: MOVEI D,1 ;RESTORE THE MAGIC AC NUMBER
AG: MOVE LPSA,A ;SEMANTICS OF THIS ARRAY
PUSHJ P,GETADL ;FILL UP THINGS.
GLOC <
TRNN TBITS,GLOBL ;IF EITHER OF THESE, THEN...
>;GLOC
TLNN TBITS,SBSCRP ;NOT IF REAL ARRAY.
JRST [PUSH P,PNT ;REMEMBER
;; #OD ! (1-2) PASS TYPE BITS TO ITMRY
SETZM BYTES
;; #LO AN ITEMVAR IS NOT AN ITEM
TRNN TBITS,ITMVAR ;IF ITEMVAR NO ITEM NO.
TRNN TBITS,LPARRAY ;IF ITEM TYPE, THEN
JRST LXXL ;
MOVE PNT,$VAL2(PNT) ;PICK UP SEMANTICS OF ITEM NO.
EMIT <PUSH RP,NOUSAC> ;AND STACK ITEM NUMBER.
;; #OD (2-2)
MOVE A,TBITS
PUSHJ P,ITMTYP
HRLZM A,BYTES
LXXL:
;; #OD#
GLOC <
TRNE TBITS,GLOBL ;...
AOS LEPGLB ;SAY IT IS GLOBAL.
PUSHJ P,GLBST2 ;LET GLOBAL REALLY KNOW
>;GLOC
LPCALL (ITMRY) ;THIS WILL DO ALL THE WORK.
POP P,PNT ;RESTORE.
JRST AG0]
XCALL <ARMAK>
AG0:
HRRI FF,0
TLNE TBITS,SBSCRP ;IF A REGULAR ARRAY.
GENMOV (PUT) ;STORE THE AC1 ANSWER.
TESTIT: TRNN ARRBIT,777776
JRST ADCND
MOVE A,[ADD RP,NOUSAC]
MOVE PNT,PNT2
PUSHJ P,EMITER
JRST ADCND
STOWN:
REN <
PUSHJ P,LOSET ;SWITCH TO DATA PC
>;REN
SETOM OWNWD ;OWN ARRAY
SKIPE BLKOK ;>5-D OUTER ARRAYS CAUSE TROUBLE
ERR <OUTER LEVEL ARRAYS OF OVER 5-D DON'T WORK>,1
MOVE TBITS,ARYBITS
REN <
SKIPE HISW ;JUMPING AROUND ARRAYS NOT
JRST NOJ ; NECESSARY IN RE-ENTRANT PROGRAM
>;REN
MOVE TEMP,TPROC ;IF JUMP AROUND PROCEDURES HAS
HLRZ TEMP,%TLINK(TEMP) ; BEEN ISSUED, WE'LL JUST USE
MOVE A,[JRST NOUSAC!NOADDR]
SKIPN $SBITS(TEMP) ; IT BELOW TO GET AROUND ARRAY
PUSHJ P,EMITER ;OTHERWISE ISSUE JUMP
NOJ: PUSH P,PCNT ;WILL NEED FOR FIXUP LATER
EMIT <NORLC!NOADDR!NOUSAC> ;0, BECOMES A POINTER LATER
MOVN TEMP,DIMNO
IMULI TEMP,3
SUB TEMP,ARRSIZ
SUBI TEMP,5 ;-(ARRAY SIZE + 5+3*DIMNO)
MOVE A,[XWD -1,NORLC!NOUSAC!USADDR]
HRL C,TEMP
PUSHJ P,EMITER ;ARRAY SIZE WORD
HRL A,LEFMRK ;-1 FOR STRING, 0 OTHERWISE
HRRI A,NOUSAC!NOADDR ;WILL BE 0,0,0 WORD
PUSHJ P,EMITER ;LEAVE ROOM
MOVE D,DIMNO ;THIS LOOP AGAIN!
LSH D,1 ;*2 TO INDEX BLOCK
ADDI D,1 ;NULLIFY FIRST SOJE
HEDLUP: SOJE D,FINHED
HLLE C,ARYBLK-1(D) ;LOWER BOUND
HRL A,C
HRRI A,USADDR!NORLC!NOUSAC ;PUT IT OUT
PUSHJ P,EMITER
HRLE C,ARYBLK-2(D) ;UPPER BOUND THIS DIM
HRL A,C ;PUT OUT UPPER
PUSHJ P,EMITER ; BOUND
HRL C,ARYBLK-1(D) ;MULTIPLY FACTOR
EMIT <USADDR!NORLC!NOUSAC> ;PUT IT THERE TOO
SOJA D,HEDLUP
FINHED: MOVE TEMP,DIMNO ;ONE MORE TIME
TRNE TBITS,STRING
MOVNS TEMP ;#DIMENSIONS, - IF STRING
HRL A,TEMP
HRRI A,NOUSAC!NORLC!USADDR
HRL C,ARRSIZ
PUSHJ P,EMITER ;#DIMS,,TOTAL SIZE
HRL B,(P) ;FIXUP ADR OF HEAD OF ARRAY
HRR B,PCNT ;ADR OF 1ST DATA WORD
HRRM B,OWNWD ;SAVE IT
PUSHJ P,FBOUT ;LET HDR PNT TO 1ST DATA WORD
;; #MO#! NOW LDYFLG< 0 MEANS PRELOAD, >0 MEANS INNER BLOCK OWN ARRAY
SKIPL LDYFLG ;IS THIS A PRELOADED ARRAY ?
JRST NOPRE ;NO -- GO AHEAD AS USUAL.....
PUSHJ P,LDYOUT ;PUT OUT CONSTANTS INTO ARRAY
JRST NOADPC ;DON'T ADD TO PCNT AGAIN
NOPRE: PUSHJ P,FRBT ;FORCE OUT BINARY
MOVE TEMP,ARRSIZ ;GET OVER ARRAY
ADDM TEMP,PCNT ;BY THIS MUCH
NOADPC: HRL C,(P) ;HDR ADDRESS AGAIN
MOVE A,[XWD 400000,USADDR!NOUSAC]
PUSHJ P,EMITER ;SIGN BIT,,ADDR OF HEAD
TRNN TBITS,STRING ;PUT OUT LINKAGE
JRST NSTR ; BLOCK IF STRING ARRAY
HRRZ TEMP,ARRSIZ ;COMPUTE NUMBER OF STRINGS
LSH TEMP,-1
HRL A,TEMP
HRL C,OWNWD ;ARRAY LOCATION (1ST STRING)
HRRI A,NOUSAC!USADDR
PUSHJ P,EMITER ;PUT IT OUT
EMIT <NOADDR!NOUSAC> ;LINK GOES THRU HERE
MOVEI B,1 ;STRING LINK BLOCK.
PUSHJ P,LNKOUT ;PUT OUT LINK BLOCK
NSTR:
REN <
PUSHJ P,HISET ;SWITCH BACK TO PROGRAM PC
>;REN
PUSHJ P,ENDJMP ;FIX UP JUMP AROUND PROC TO HERE, IF NECC.
JRST ALJMPD ; NO MORE NEEDED (SEE ENDDEC,PRDEC)
MOVE B,(P) ;HDR ADDR
SUBI B,1 ;JRST ADDR
HRL B,PCNT
REN <
SKIPN HISW ;DON'T DO JUMP IF RE-ENTRANT PROG
>;REN
PUSHJ P,FBOSWP ;JRST FIXUP
ALJMPD:
;;# # RHT MAKE OWN ARRAYS NOT ZEROED
TLNE TBITS,OWN
TRNE TBITS,ITEM
JRST LDYFOK ;NOT OWN NON-ITEM
MOVE A,LEVEL ;STILL ZERO OUTER BLOCKS
CAIL A,2 ;
;;#MG# ! RHT 2 OF 3 LEAVES LH 0 IF REALLY ONLY OWN
HLLOS LDYFLG ;SET THE FLAG (LEAVE LEFT HALF OK)
LDYFOK:
HRL C,OWNWD ;ARRAY LOCATION
MOVE A,[SETZM NOUSAC!USADDR] ;SETZM 1ST DATA WORD.
SKIPN LDYFLG
PUSHJ P,EMITER ;PUT IT OUT IF NOT PRE-LOADED ARRAY.
MOVE A,[HRLI RTEMP,NOUSAC!USADDR] ;HRLI TEMP, 1ST WORD.
TRNN TBITS,LPARRAY ;ALWAYS IF LEAP TYPE ARRAY
SKIPN LDYFLG
PUSHJ P,EMITER
TRNE TBITS,ITEM
TRNN TBITS,LPARRAY
JRST NORCIT
PUSH P,C
; NOW THIS C, THE ARRAY HEADER PCNT, AND THE ARRAY SEMANTICS ARE IN THE PSTACK
MOVE PNT,-2(P) ;SO THIS IS HOW TO GET SEMANTICS
MOVE PNT,$VAL2(PNT) ;POINTER TO INTEGER AGAIN.
EMIT <PUSH RP,NOUSAC>
LPCALL (ITMYR) ;ALL THE WORK IS DONE HERE.
POP P,C
NORCIT:
SKIPE LDYFLG ;PRELOADING ?
JRST FXBLK ;YES -- FINISH UP...
ADD C,[XWD 1,0]
EMIT <HRRI RTEMP,NOUSAC!USADDR> ;HRRI TEMP,2D WORD
HRRZ TEMP,OWNWD ;ARRAY LOC
ADD TEMP,ARRSIZ
HRLI C,-1(TEMP) ;LAST WORD
EMIT <BLT RTEMP,NOUSAC!USADDR> ;BLT TEMP,LAST WORD
FXBLK: TRNE TBITS,STRING ;NAME ARRAY LOC IF BILTIN
AOS OWNWD ;1 PAST IF STRING
POP P,B ;HDR ADDR, ONE MORE TIME
ADDI B,2 ;ADDR OF 0,0,0 WORD
MOVE TEMP,OWNWD ;UPDATED ARRAY LOC
SUB TEMP,ARRDSP ;TOTAL DISPLACEMENT
HRL B,TEMP
MOVSS B ;ADDR,FIXUP
PUSHJ P,FBOUT
ADCND:
; NOW MAKE A BLOCK FOR EACH ARRAY, SET UP #DIMS, STORE ADDRESS
MOVE A,DIMNO ;#DIMENSIONS
;;#HN#! 6-6-72 DCS USE LEFMRK ONLY IF OWNWD (BUILT-IN)-- 0 IF DYNAMIC!
SKIPE B,OWNWD ;ADDR OF BEGINNING OF ARRAY
HRL B,LEFMRK ;-1 FOR STRING, 0 ELSE
MOVEI C,0 ;ASSUME ¬KNOWALL
SKIPN NOMULT ;TEST ASSUMPTION
MOVSI C,KNOWALL ;WRONG
MOVE D,OWNWD
SUB D,ARRDSP ;DISPLACEMENT, IF KNOWN
POP P,PNT ;USE SEMANTICS OF THIS ARRAY, SAVED AT STARLP
HRLM A,NUMDIM(PNT) ;NUMBER OF DIMENSIONS
HRLM D,TOTDSP(PNT) ;DISPLACEMENT IF KNOWN
MOVEM B,ARLOC(PNT) ;LOCATION IF KNOWN
;; #PP# WARN ABOUT FIXUP PROBLEMS
REN <
ADDI B,(D) ;VIRTUAL ORIGIN
SKIPE HISW ;IF NOT REENTRANT
TRNN B,400000 ;OR NOT NEGATIVE
JRST NWORRY ;WON'T CAUSE FIXUP PROBLEM
SKIPE OWNWD ;DON'T WORRY IF NOT AN OWN ARRAY
ERR <VIRTUAL ORIGIN OF OUTER-BLOCK OR OWN ARRAY BEFORE START OF REL FILE.
PROCEED AT YOUR PERIL>,1
NWORRY:
>;REN
ORM C,$SBITS(PNT) ;ADD KNOWALL BIT
SKIPE BLKOK ;CAN WE PREPARE A BOUNDS BLOCK?
JRST NOBDBK ; NO BNDBLK
GETBLK <LPSA> ;NEW BLOCK TO HOLD IT
MOVSI TEMP,ARYBLK ;SOURCE
HRR TEMP,LPSA ;DEST
BLT TEMP,=10-1(LPSA) ;SAVE BNDBLK INFO
HRLM LPSA,%TLINK(PNT) ;PTR TO BNDBLK
NOBDBK: SOJG ARRBIT,STARLP ;GET THEM ALL
FINIT: SETZM ARYLST ;CLEAR SOMETHING ANYHOW
;;#MI# (1 OF 1) RHT MUST ALWAYS CLEAR LDYFLG
MOVEI TEMP,0 ;
EXCH TEMP,LDYFLG ;ZERO IT OUT
;;#MI#
;;#MG# RHT ! ONLY NEG IF REALLY PRELOAD
JUMPL TEMP,FINLUP ;
POPJ P, ;ALL DONE HERE
FINLUP: QPOP (LDYSTK) ;POP OFF THINGS.
JUMPN A,FINLUP ;UNTIL THE 0 THAT STARTED THINGS.
POPJ P, ;DONE AT LAST.
EXARST: MOVE B,ARYLST ;ONLY THE ESSENTIALS
MOVE SBITS2,DIMNO ;FOR EXTERNAL ARRAYS
;;#GP# DCS 2-7-72 (2-2) WARNING ON PRELOADED EXTERNAL ARRAYS
SKIPGE LDYFLG ;DID HE REALLY DO THIS?
ERR <YOU CAN'T LOAD THAT ARRAY FROM HERE>,1
;;#GP# (2)
AGEX: QPOP (ARYPDL) ;SEMANTICS FOR THIS ARRAY
HRLM SBITS2,$ACNO(A) ;STORE NUMBER OF DIMENSIONS
SOJG B,AGEX ;DON'T QUIT UNTIL DONE
JRST FINIT ;NOW STOP
DSCR LDYBEG, LDYREP, LDYNO
PRO LDYBEG LDYREP LDYNO
DES EXECS for PRELOAD specifications
⊗
↑LDYBEG: MOVEI A,0
QPUSH (LDYSTK) ;PUSH IT ON.
MOVE A,LDYSTK
MOVEM A,LDYTAK ;FOR THE QTAKE OPERATION.
SETZM CURENT
SETOM LDYFLG ;TO TELL ARRDEC.
SETZM LDYTOT ;AND TOTAL SIZE.
POPJ P,
↑LDYREP: GETSEM (1) ;REPEAT ARGUMENT
TLNN TBITS,CNST ;MUST BE CONSTANT.
ERR <VARIABLE REPEAT ARGUMENT>,1
MOVE A,$VAL(PNT) ;CONSTANT
HRLM A,CURENT ;AND SAVE IT.
POPJ P,
↑LDYNO: GETSEM (1) ;THE CONSTANT TO LOAD
TLNN TBITS,CNST ;A REAL CONSTANT?
ERR <VARIABLE IN PRELOAD>,1
MOVE A,PNT
HLL A,CURENT
TLNN A,-1 ;IF SOME REPEAT ARG.
TLO A,1
SETZM CURENT
QPUSH (LDYSTK) ;STACK IT.
HLRZ A,A
ADDM A,LDYTOT ;UPDATE TOTAL SIZE.
POPJ P,
LDYOUT: TRNN TBITS,ITMVAR!INTEGR!FLOTNG!STRING ;ONLY FOR THESE TYPES.
JRST [ERR <ONLY ALGEBRAIC PRELOADED ARRAYS>,1
JRST LPOPJ]
;;#PE# THERE WERE 4 TERRIBLE INSTRUCTIONS HERE THAT CLOBBERED LDYTOT -- RHT
PUSH P,ARRSIZ ;SAVE IT
PUSH P,PNT ;GET AN ACCUMULATOR
PUSH P,SBITS ;AND ANOTHER
PUSH P,TBITS ;AND A THIRD.
MOVE B,LDYTAK ;THE QTAKE POINTER.
LDYLOP: QTAKE (LDYSTK) ;GET AN ENTRY XWD REPEAT #,,SEMANTICS OF CONSTANT.
JRST LDYFIQ ;NO MORE LEFT.....
PUSH P,B ;SAVE QTAKE POINTER.
MOVE PNT,A
HLRZ D,A ;REPEAT COUNT.
PUSHJ P,GETAD ;GET THE GOOD BITS.
TLNN TBITS,CNST ;IF NOT, YOU HAVE LOST VERY BIG......
ERR <CONSTANTS ONLY IN LOADED ARRAYS>,1
MOVE B,-1(P) ;TYPE OF ARRAY
TRZ B,ITEM!ITMVAR!LPARRAY ;NOT THESE TYPES.
GENMOV (CONV,INSIST) ;ALRIGHT BOYS....
LDYG2: MOVE A,$VAL(PNT) ;THIS IS THE CONSTANT.....
TRNE TBITS,STRING ;WOW -----
HRRZ A,$PNAME(PNT) ;GET THE LENGTH WORD.
TLZ FF,RELOC
PUSHJ P,CODOUT ;AND PUT OUT THE WORD.....
TRNN TBITS,STRING ;ANOTHER WORD IF STRING.
JRST LDYG1 ;LOOP OTHERWISE.
MOVS C,PCNT ;OH DEAR
EXCH C,$VAL(PNT) ;HERE (FOR STRINOS) WE STORE THE FIXUP.
MOVE A,[POINT 7,USADDR!NOUSAC]
PUSHJ P,EMITER ;AND EMIT IT.....
SOS ARRSIZ ;DECREASE SIZE LEFT.
LDYG1: SOSG ARRSIZ ;MORE LEFT?
JRST LDYFIN ;NO
SOJG D,LDYG2 ;LOOP UNTIL REPEAT EXHAUSTED.
POP P,B ;QTAKE POINTER
JRST LDYLOP ;AND KEEP GOING.
LDYFIN: POP P,B
LDYFIQ:
POP P,TBITS ;RESTORE ALL THE SAVED AC'S
POP P,SBITS
POP P,PNT
POP P,ARRSIZ ;AND THE SIZE
;;#PE# USED TO USE A (CLOBBERED) LDYTOT HERE -- RHT -- 11-26-73
MOVN B,LDYTOT ;NUMBER OF WORDS
TRNE TBITS,STRING ;TWICE AS MANY IF STRING
ASH B,1 ;TIMES TWO
ADD B,ARRSIZ ;GET WHAT IS LEFT
;;#PE#
JUMPE B,LPOPJ ;FITS JUST FINE.
JUMPL B,[ERR <WARNING -- PRELOADED RANGES TOO LARGE>,1
JRST LPOPJ]
MOVEI A,0
TLZ FF,RELOC
PUSHJ P,CODOUT ;MAKE UP THE DIFFERENCE
SOJG B,.-1
LPOPJ: POPJ P, ;DONE
DSCR ARYIDX, ARRSBY, ARRSB1
PRO ARYIDX ARRSBY ARRSB1
DES ARYIDX initializes for an array-subscripting operation
ARRSBY is called for every actual index but the last
ARRSB1 is called for the last index, issues final code
SEE Comments at beginning of ARRAY for details
⊗
↑ARYIDX:
GETBLK <PNT2> ;PNT2 PNTS TO IDXBLK
GETSEM (1) ;SEMANTICS OF ARR
HRRZM PNT,%TBUCK(PNT2) ;SAVE PTR TO ARR IN IDXBLK
HLRZ TEMP,%TLINK(PNT) ;PTR TO BNDBLK FOR THIS ARRAY
MOVEM TEMP,BNDPNT(PNT2) ;SAVE IN IDXBLK
HLRZ TEMP,NUMDIM(PNT) ;#DIMENSIONS
TLNE TBITS,FORMAL ;INDEFINITE IF FORMAL
TRO TEMP,-1 ; (DON'T KNOW REAL NUMBER)
MOVEM TEMP,NUMDIM(PNT2)
MOVEM PNT2,GENRIG ;THIS IS THE ANSWER
POPJ P,
JRST LPOPJ]
; FIRST PART SETS UP ARRBIT TO INDICATE EXACT CONDITIONS
↑ARRSBY: SKIPA ARRBIT,[XWD MANYD!NOTLST!IDXVAR!DANGAR,0] ;NOT LAST INDEX
↑ARRSB1: MOVSI ARRBIT,MANYD!LSTIDX!IDXVAR!DANGAR ;LAST INDEX
HRRZ PNT2,GENLEF+2 ;IDXBLK SEMANTICS
AOS TBLIDX,DIMPRC(PNT2) ;COUNT #DIMS PROCESSED
CAMLE TBLIDX,NUMDIM(PNT2) ;TOO MANY?
ERR <TOO MANY DIMENSIONS IN SUBSCRIPT>,1
SOJN TBLIDX,NOTONE ;CHECK 1-D ARRAY
TLNE ARRBIT,LSTIDX ;LSTIDX and DIMPRC=1 implies ONED
TLC ARRBIT,ONED!MANYD ;RESET CONDITIONS
NOTONE: MOVNI TBLIDX,1(TBLIDX) ; -DIMNO
IMULI TBLIDX,3 ;INDEX INTO ARRAY DESCRIPTOR
HRRZ PNT,%TBUCK(PNT2) ;SEMANTICS OF ARRAY
PUSHJ P,GETAD
TRNE TBITS,STRING ;IF STRING ARRAY, ADJUST
SUBI TBLIDX,1 ; DISPLACEMENT INTO TABLE
TLNE TBITS,SAFE ;ADJUST FOR SAFETY
TLC ARRBIT,SAFEAR!DANGAR
TLNE SBITS,ARTEMP ;IF ARTEMP, THEN DATUM OF ITEMVAR
TLO ARRBIT,DATMR
SETZM SIZZ ;IN CASE NO BITS KNOWN
SKIPN B,BNDPNT(PNT2) ;BOUNDS BLOCK POINTER
TLO ARRBIT,NOMUL!LOWVAR!SOMVAR ;NO BITS, ADD DEFAULT ONES
JUMPE B,MKTST ; AND SKIP BIT LOAD
OR ARRBIT,(B) ;SET UP BITS FROM BOUNDS BLOCK
MOVEW (SIZZ,<1(B)>) ;LOWER BOUND AND MULTIPLIER FOR THIS DIM.
ADDI B,2
MOVEM B,BNDPNT(PNT2) ;UPDATE BOUNDS POINTER
; FINISH SETTING BITS
MKTST: MOVE TEMP,GENLEF+1 ;INDEX SEMANTICS
MOVE TEMP,$TBITS(TEMP) ;TBITS FOR INDEX
TLNE TEMP,CNST ;CONSTANT INDEX?
TLC ARRBIT,IDXCON!IDXVAR ; YES, MAYBE SIMPLER
TLNE ARRBIT,LSTIDX ;IF LAST INDEX,
TLZ ARRBIT,MULMUL!NOMUL ; EASE OF MULTIPLICATION IRRELEVANT
; NOW LOAD ARRAY ADDRESS IF NUMUL or ¬SAFE and SOMVAR
TLNN ARRBIT,NOMUL ;MUST IF HAVE TO DO IMUL
TLNN ARRBIT,SAFEAR!BOTFIX ;ALSO IF DANGAR and SOMVAR
JRST [TLO ARRBIT,GOTARR ;AND GOT ARRAY INTO AC.
GENMOV (GET,INDX) ;NO HELP FOR IT.
HRROS ACKTAB(D) ;PROTECT OVER GETTING THE INDEX VARB.
HRLS D ;COPY FOR DOING INDEXING.
JRST .+1]
; MAKE SURE INDEX IS LOADED IF HAVE TO EMIT BOUNDS-CHECKING CODE
MOVE PNT,GENLEF+1 ;INDEX SEMANTICS
;;#FP# 1-10-72 DCS (1-1)
GENMOV (CONV,INSIST!GETD!POSIT!INDX,INTEGR);REQUIRE THESE
;THINGS, DON'T GET UNLESS NEEDED
; WAS GENMOV (CONV,INSIST!GETD,INTEGR) ;REQUIRE AT LEAST THIS MUCH
;;#FP# This will avoid some redundant instructions
MOVEM PNT,GENLEF+1 ;SAVE ANY NEW SEMANTICS
MOVE SP,$VAL(PNT) ;IN CASE CONSTANT
TLNE ARRBIT,SAFEAR ;FORGET IF SAFE
JRST GUDGUY
HRRI FF,INDX!POSIT ;IN CASE HAVE TO LOAD
TLNE ARRBIT,IDXVAR!SOMVAR ;IF IDXCON and BOTFIX, DON'T LOAD
GENMOV (GET) ;1 INSTR ONLY
MOVEM PNT,GENLEF+1 ;IN CASE SEMANTICS CHANGED
; DO BOUNDS CHECKING -- LOWER
LOWCHK: HRRI C,1 ;BITS FOR CA(M/I)L
TLNN ARRBIT,IDXVAR!LOWVAR ;IF NOTHING MOVES
JRST [HLRE TEMP,SIZZ ;LOWER
CAMGE SP,TEMP ;UNDERFLOW?
ERR <YOU'LL HAVE SUBSCRIPT UNDERFLOW>,1
JRST CHKOVF]
TLNN ARRBIT,IDXVAR!SOMVAR ;WILL WE ISSUE 2D INST?
MOVEI C,5 ;NO, BITS FOR CA(M/I)GE
TLNN ARRBIT,LOWFIX ;TRY FOR "CAIL"?
JRST DOCAML ; NO, GET FROM ARRAY TABLE
HLL C,SIZZ ;LOWER BOUND
TLNN C,400000 ;NEGATIVE??
JRST DOCAIL ; NO, WE WIN
HLRE A,C ;MAKE INTEGER CONSTANT
PUSHJ P,CREINT
MOVE A,[CAM USCOND] ;WILL USE CAML
JRST LOUT
DOCAML: HRLI C,-1(TBLIDX) ;-1-3*DIMNO
SKIPA A,[CAM USADDR!NORLC!USX!USCOND] ;WORST CASE
DOCAIL: MOVE A,[CAI USADDR!NORLC!USCOND] ;BEST CASE
LOUT: PUSHJ P,EMITER
; CHECK UPPER BOUNDS
CHKOVF: TLNN ARRBIT,IDXVAR!SOMVAR ;IF NOTHING MOVES
JRST [CAILE SP,(ARRBIT) ;CHECK AT COMPILE TIME
ERR <YOU'LL HAVE SUBSCRIPT OVERFLOW>,1
JRST GUDGUY] ;AND OUT
TLNN ARRBIT,BOTFIX ;DON'T WORRY ABOUT HIFIX ONLY
JRST NOCAILE
HRL C,ARRBIT ;UPPER BOUND
TRNN C,400000 ;SEE ABOVE
JRST DOIMM
HLRE A,C
PUSHJ P,CREINT
MOVE A,[CAMLE]
JRST LEOUT
NOCAILE: HRLI C,-1+1(TBLIDX) ;-1-*DIMNO+1(ARRX)
SKIPA A,[CAMLE USADDR!USX!NORLC]
DOIMM: MOVE A,[CAILE USADDR!NORLC]
LEOUT: PUSHJ P,EMITER ;BOUNDS CHECK INSTRUCTION
; PUT OUT ERROR UUO
MKERR: MOVEI TEMP,PNAME-1
MOVSI A,(<ARERR>)
HRRZ PNT,%TBUCK(PNT2) ;PTR TO ARRAY SEMANTICS
TLNE ARRBIT,DATMR ;IS THIS THE DATUM OF AN ARRAY?
;;#KR# DCS 12-6-72 (1-1) SOME ITEMVARS JUST DON'T HAVE NAMES
HRRZ PNT,$VAL(PNT)
JUMPN PNT,STRERR
MOVEI PNT,[=9
POINT 7,[ASCII /*UNKNOWN*/]]-$PNAME
STRERR: PUSH TEMP,$PNAME(PNT) ;MAKE STRING CONSTANT FOR ERROR GUY
;;#KR#
PUSH TEMP,$PNAME+1(PNT)
PUSHJ P,STRINS
EMNAM: EXCH D,DIMPRC(PNT2) ;THIS DIMENSION AS AC FIELD
PUSHJ P,EMITER ;ARERR DIMNO,"ARRAY NAME"
EXCH D,DIMPRC(PNT2)
; NOW SEE IF INDEX NEEDED IN AC FOR MULTIPLYING PURPOSES (OR ONED)
GUDGUY: TLNN ARRBIT,NOMUL!IDXVAR ;CAN IT ALL BE DONE NOW?
JRST [HRRZ TEMP,SIZZ ;MULTIPLY FACTOR
TLNE ARRBIT,MULMUL ;SHOULD MULTIPLY BE DONE?
IMUL SP,TEMP ;YES, DO IT
ADDM SP,$VAL(PNT2) ;UPDATE TOTAL DISPLACEMENT
MOVE PNT,GENLEF+1 ;ALSO REMOP THE INDEX EXPRESSION.
JRST REVR1] ; AND UNPROTECT THE ARRAY AC
TLNN ARRBIT,NOTLST!ONED!DANGAR ;CAN WE ADD INSTEAD OF MOVE?
JRST ADDREV ;YES
SEMGET: MOVE PNT,GENLEF+1 ;GET INDEX SEMANTICS AGAIN
GENMOV (GET,INDX!POSIT!INSIST!GETD,INTEGR) ;LOAD IT, IF NOT ALREADY
PUSHJ P,REMOP ;DO NOT FORGET TO REMOP INDEX.
TLNE ARRBIT,LSTIDX ;NEED WE MULTIPLY?
JRST NOMLT ; NOPE
TLNE ARRBIT,NOMUL ;CAN WE DO AN IMULI?
JRST DOMUL ; NO, AN IMUL
DOMULI: HRL C,SIZZ ;MULTIPLY FACTOR
TLNN C,-1 ;0 MULTIPLE INVALID
ERR <DRYROT --0 MULTIPLE??>
TLNN C,777776 ;1?
JRST NOMLT ; DON'T MULTIPLY BY 1
EMIT <IMULI NORLC!USADDR>
JRST NOMLT
DOMUL: HRLI C,1(TBLIDX) ;-1-3*DIMNO+2 -- MULTIPLY FACTOR
EMIT <IMUL USADDR+USX+NORLC> ;IMUL AC,-1-3*DIMNO+2(ARRX)
; NOW ADD OR CREATE PARTIAL TEMP
NOMLT: PUSHJ P,MARKINT ;MARK AS INTEGER.
LEFT PNT2,%TLINK,,
HRLM PNT,%TLINK(PNT2) ;GET OLD SEMANTICS, STORE NEW
MOVEI PNT,0 ;MAKE REMOP HARMLESS IF JUMP IS TAKEN
JUMPE LPSA,REVR1; ;FRST INDX CLC, UNPROTECT ARRAY AC
PUSHJ P,GETADL ;SEMANTICS OF OLD PARTIAL
REVRET: EMIT <ADD> ;ADD AC,OLD PARTIAL
REVR1: MOVS TEMP,D ;ARRAY INDEX REG
TLNE ARRBIT,GOTARR ;UNPRTCT IF WE PICKED UP ARRAY DSCRPTR
HRRZS ACKTAB(TEMP)
JRST REMOP ;REMOVE OLD AND RETURN
ADDREV: HLRZ PNT,%TLINK(PNT2) ;ADD IN THE OPPOSITE DIRECTION
JUMPE PNT,SEMGET ; UNLESS THIS IS FIRST INDEX
;(IT SHOULDN'T BE BECAUSE OF ABOVE CONDITIONS
GENMOV (GET,INDX!GETD) ;GET OLD TEMP BACK
MOVE PNT,GENLEF+1 ;SEMANTICS OF THIS INDEX
GENMOV (CONV,INSIST!POSIT!GETD,INTEGR) ;MAKE SURE IT IS THE RIGHT SHAPE
JRST REVRET ;ADD IN INVERSE ORDER
DSCR SUBSCR
PRO SUBSCR
DES Issues final code for array subscripting operation
⊗
↑SUBSCR: HRRZ PNT2,GENLEF+2 ;IDXBLK SEMANTICS
HRRZ LPSA,%TBUCK(PNT2) ;SEMANTICS OF ARRAY
HLRZ PNT,%TLINK(PNT2) ;SEMANTICS OF PARTIAL CALCS
HRRE TEMP,NUMDIM(PNT2) ;CHECK CORRECT CALL
JUMPL TEMP,SUBIGN ;CAN'T CHECK IT
CAME TEMP,DIMPRC(PNT2) ;CHECK IT
ERR <NOT ENOUGH SUBSCRIPTS SUPPLIED TO >,3
SUBIGN: EXCH LPSA,PNT2 ;PNT2 IS ARRAY SEMANTICS
MOVE B,DIMPRC(LPSA) ;ACTUAL NUMBER OF DIMENSIONS SEEN.
MOVE TBLIDX,$VAL(LPSA) ;GET TOTAL CONTRIBUTION OF CONSTS
FREBLK () ;RELEASE IDXBLK
MOVE SP,$TBITS(PNT2) ;TBITS FROM ARRAY (GET OWN)
;; #RE# (1 OF 2) A STRING ITEMVAR ARRAY OR STRING ARRAY ITEMVAR ARRAY IS NOT A STRING
TRNE SP,ITMVAR
TRZ SP,STRING
;; #RE#
MOVEI ARRBIT,0 ;FLAGS FOR THIS CALC
SKIPE PNT ;ANY PARTIAL CALCS?
TLO ARRBIT,NOTCLC!SOMCLC ; YES (NOTCLC STORED INVERTED)
TLNN SP,OWN ;BUILT-IN ARRAY?
TLO ARRBIT,OWN ; NO, SET INVERTED SENSE
TRNE SP,STRING ;STRING ARRAY?
LSH TBLIDX,1 ; YES, SHIFT THIS
MOVE TEMP,$SBITS(PNT2) ;NOW CHECK TOTDSP KNOWLEDGE
TLNN TEMP,KNOWALL ;HAVE WE GOT ENTIRE OFFSET?
TLO ARRBIT,KNOWALL ;NO (KNOWALL STORED INVERTED)
JUMPE PNT,NOGT ;NO PARTIAL CALCS
GENMOV (GET,GETD!INDX) ;MAKE SURE IN AC
HRL SP,D ;SAVE AC OF PARTIAL CALCS
HRLI C,1 ;GET READY FOR LSH IF STRING
MOVE A,[LSH USADDR!NORLC]
TRNE SP,STRING
PUSHJ P,EMITER ;DOUBLE INDEX
NOGT: EXCH PNT,PNT2 ;NOW PNT IS ARRAY SEMANTICS
PUSHJ P,GETAD ;GET BITS
;; #RE# (2 OF 2) AGAIN STRING ITEMVAR NOT STRING
TRNE TBITS,ITMVAR
TRZ TBITS,STRING
;; #RE#
TLCN ARRBIT,NOTCLC!OWN!KNOWALL ;INVERT AND TEST
JRST FXDARR ;CAN DO IT ALLL AT COMPILE TIME
; NOW ADJUST DISPLACEMENT BY TOTDSP IF KNOWALL
TLNN ARRBIT,KNOWALL ;WELL?
JRST DONKNO ;NEED [0,0,0] WORD
HLRE TEMP,TOTDSP(PNT) ;TOTDSP&POSSIBLY ARRAY ADDR
ADD TBLIDX,TEMP ;NOW TBLIDX HAS GOOD DISPL FIELD
TLNE ARRBIT,OWN!NOTCLC ;IF ¬OWN and PARTIAL CALCS,
JRST GETARP ; CAN ADD ARRAY PTR
EMIT <ADD> ;DO IT
JRST MRKIDX ;MAKE AN INDEXED TEMP, FINISH OUT
GETARP: TLNE ARRBIT,OWN ;KNOWALL,¬OWN,¬PARTIAL CALCS?
JRST MRKIDX ;NO, KNOWALL,OWN,PARTIAL CALCS
GENMOV (GET,INDX) ;GET ARRAY ADDR TO INDXABLE AC
JRST MRKIDX
DONKNO: GENMOV (GET,INDX) ;MAKE SURE ARRAY ADDR IS UP
HRLS D ;SAVE AC AS INDEX POS
HLR D,SP ;GET AC OF PARTIAL CALCS BACK
; MOVE B,DIMPRC(IDXBLK) ;NUMBER OF DIMENSIONS ACTUALLY SEEN.
IMULI B,-3
TRNE TBITS,STRING ;GET POINTER TO [0,0,0] WORD
ADDI B,-1
HRLI C,-2(B) ;TO ADDR FIELD FOR EMITER
JUMPN PNT2,ADD000 ;CAN ADD IF HAVE PARTIAL CALCS
PUSHJ P,GETAN0 ;NEED INDEXABLE AC FOR 000 WORD
SKIPA A,[MOVE USX!USADDR!NORLC]
ADD000: MOVE A,[ADD USX!USADDR!NORLC]
PUSHJ P,EMITER ;GAIN ACCESS
MRKIDX: MOVE ARRBIT,$TBITS(PNT) ;GET TYPE BITS BACK
PUSHJ P,REMOP ;REMOVE ARRAY
SKIPE PNT,PNT2 ;PARTIAL CALCS
PUSHJ P,REMOP ; REMOVE IF ANY
PUSHJ P,MARKINT ;MAKE AN INTEGER TEMP.
TLZ ARRBIT,-1≠OWN ;TURN OFF MOST LH BITS
MOVEM ARRBIT,$TBITS(PNT) ;THESE ARE THE REAL THING
MOVSI SBITS,INUSE!ARTEMP!INDXED!PTRAC
MOVEM SBITS,$SBITS(PNT) ;ALWAYS THE SAME
MOVEM TBLIDX,$VAL(PNT) ;DISPL FOR REFERENCES
MOVEM PNT,GENRIG ;RESULTS
POPJ P,
FXDARR: HLRE TEMP,TOTDSP(PNT) ;GET ALWAYS CONSTANT DISPL
ADD TBLIDX,TEMP ;INCREMENT BY CONSTANT CONTRIBUTIONS
TLZ TBITS,-1 ;TYPE OF RESULT IN RH
MOVSI SBITS,FIXARR ;SPECIAL RESULT
PUSHJ P,GETTEM ;NEED TEMP BLOCK
MOVEM TBLIDX,$ADR(LPSA) ;NON-FIXUPABLE ADDRESS RESULT
MOVEM LPSA,GENRIG ;RESULT
JRST REMOP ;REMOVE "ARRAY" FROM USE
DSCR DOSFTY
DES EXEC TO CHANGE THE SAFETY STATUS OF ARRAYS
⊗
↑DOSFTY:
MOVE LPSA,GENLEF+1 ;PICK UP ARRAY ID
MOVE TBITS,$TBITS(LPSA) ;TYPEE BITS
JRST .+1(B) ; SKIP IF MAKE!UNSAFE
TLOA TBITS,SAFE ;MAKE SAFE
TLZ TBITS,SAFE ;MAKE UNSAFE
MOVEM TBITS,$TBITS(LPSA) ;PUT BITS BACK
POPJ P,
BEND ARRAY
SUBTTL EXECS for Binary Algebraic Operators