Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00016 PAGES VERSION 17-1(18)
RECORD PAGE DESCRIPTION
00001 00001
00003 00002 HISTORY
00008 00003 Array Semblk, Routine Descriptions
00016 00004 Array Routine Data
00020 00005 Array Declaration Routines -- STARY, ENTARY
00023 00006 ARRSUB
00026 00007 ARRDEC
00032 00008 OWNARR: MOVE ARRBIT,ARYLST #ARRAYS WITH THESE DIMENSIONS
00039 00009
00044 00010 ADCND:
00048 00011 DSCR LDYBEG, LDYREP, LDYNO
00053 00012 DSCR ARYIDX, ARRSBY, ARRSB1
00055 00013 FIRST PART SETS UP ARRBIT TO INDICATE EXACT CONDITIONS
00061 00014 CHECK UPPER BOUNDS
00067 00015 DSCR SUBSCR
00074 00016 DSCR DOSFTY
00075 ENDMK
;
COMMENT HISTORY
AUTHOR,REASON
021 102100000022 ;
COMMENT
VERSION 17-1(18) 9-29-74 BY JFR BUG #TL# NEEDED ACCESS FOR ARRAY DESCRIPTOR
VERSION 17-1(17) 9-27-74 BY JFR FIX AUTHOR REASON STUFF
VERSION 17-1(16) 9-20-74 BY JFR
VERSION 17-1(15) 7-7-74 BY RHT EDIT FOR OWN RECORD PNTR ARRAYS
VERSION 17-1(14) 5-3-74 BY RHT TWEAK NUMDIM TO MAKE RECORD ARRAYS WORK
VERSION 17-1(13) 5-1-74 BY RHT TWEAK ARTEMP-STYLE ARRAYS
VERSION 17-1(12) 3-19-74 BY RHT GO OVER WITH RLS
VERSION 17-1(11) 3-17-74 BY RLS INSTALL TENEX
VERSION 17-0(10) 2-24-74 BY JRL BUG #RK#
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: *****,,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
**** in NOREC, this is the number of dims. in REC system number of dims is
stored in NDIMSD cell in BNDBLK
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)
NDIMSD __ %RSTR ;IN BNDBLK (FOR NUMBER OF DIMS)
; 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 OR PRESET
;;#MG# RHT 1 OF 3
; -1 IF REALLY PRELOADED 777777 IF MERELY
;OWN ARRAY.
;;#MG#
?LDCNST: 0 ;ON DURING ARRAY ALLOC IF PRESET
;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:
;;#UU# 2! JFR 8-14-75 OWN EXTERNAL ARRAY caused bad access code
TLNE B,EXTRNL ;EXTERNAL?
TLZ B,OWN ; YES, IGNORE OWN
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
;; #RK#(1 OF 5) ! AN ITEMVAR IS NOT A STRING
TRNN TBITS,ITEM!ITMVAR ;
TRNN TBITS,STRING!DBLPRC ;DOUBLE SIZES FOR STRING ARRAYS AND LONG ARRAYS
JRST MKRY1
TRNN TBITS,DBLPRC
SETOM LEFMRK ;ONLY FOR STRINGS
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
TRNE TBITS,DBLPRC ;KLUGE IT
TLO A,40 ; FOR LONGS
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 <
SKIPN HISW ;REENTRANT COMPILATION AND
JRST DLOSET
SKIPGE LDYFLG ;PRELOADED AND
SKIPN LDCNST ;PRESET ARRAY?
JRST DLOSET ;NO
PUSHJ P,HISET
SKIPA ;OVER NEXT INST
DLOSET: PUSHJ P,LOSET ;SWITCH TO DATA PC
>;REN
SETOM OWNWD ;OWN ARRAY
SKIPE BLKOK ;GTR 5-D OUTER ARRAYS CAUSE TROUBLE
ERR <OUTER LEVEL ARRAYS OF OVER 5-D DON'T WORK>,1
MOVE TBITS,ARYBITS
REN <
SKIPN HISW ;JUMPING AROUND ARRAYS NOT
JRST NEDJMP ; NECESSARY IN RE-ENTRANT PROGRAM
SKIPGE LDYFLG ;UNLESS PRELOADING AND
SKIPN LDCNST ; PRESETTING
JRST NOJ ;
NEDJMP:
>;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
HLRZ TEMP,C
CAIN TEMP,1 ;MULT FOR LAST DIM?
TRNN TBITS,DBLPRC ;ON DOUBLE ARRAY?
TLZA A,-1 ;NO, CLEAR LEFT HALF OF MULT
HRLI A,40 ;YES, MARK IT SPECIAL
PUSHJ P,EMITER
SOJA D,HEDLUP
FINHED: MOVE TEMP,DIMNO ;ONE MORE TIME
;;#RK#(2 OF 5) AN ITEMVAR IS NOT A STRING
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING
JRST .+2
;; #RK#
MOVNS TEMP ;#DIMENSIONS, - IF STRING
HRL A,TEMP
HRRI A,NOUSAC!NORLC!USADDR
HRL C,ARRSIZ
PUSHJ P,EMITER ;#DIMS,,TOTAL SIZE
OPTSYM %$ARRY ;FIRST DATA WORD OF OWN ARRAY
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
RGC <
TRNE TBITS,PNTVAR ;OWN RECORD ARRAY?
TRNE TBITS,ITEM!ITMVAR
JRST FINH.1 ;NOPE
MOVN A,ARRSIZ ;NUMBER OF WORDS
MOVS A,A
HRR A,OWNWD ;-CNT,,ADR
QPUSH (RBSTK) ;SO THIS OWN ARRAY WILL BE MARKED
FINH.1:
>;RGC
;; #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
;; #RK# (3 OF 5) AN ITEMVAR IS NOT A STRING
TRNN TBITS,ITEM!ITMVAR
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,%STLNK ;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 ;MUST JUMP IF NOT REENTRANT PROGRAM
JRST ALNDJP
SKIPGE LDYFLG ;OR IF PRELOADING
SKIPN LDCNST ;AND PRESETTING
JRST ALJMPD
>;REN
ALNDJP:
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:
;; #RK# (4 OF 5) ITEMVAR NOT A STRING
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING ;NAME LOC IF BILTIN
JRST .+2
;; #RK#
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
NOREC <
HRLM A,NUMDIM(PNT) ;NUMBER OF DIMENSIONS
>;NOREC
REC <
;;% % MOVED NUMDIMS TO BNDBLK
GETBLK <LPSA> ;NOW ALWAYS GET BNDBLK
HRLM LPSA,%TLINK(PNT) ;
HRLM A,NDIMSD(LPSA) ;
>;REC
HRLM D,TOTDSP(PNT) ;DISPLACEMENT IF KNOWN
MOVEM B,ARLOC(PNT) ;LOCATION IF KNOWN
;; #PP# WARN ABOUT FIXUP PROBLEMS
REN <
;;***** ! MAY HAVE SOME FUNNYNESS HERE *****
;[clh] The logic here is very obscure. They seem to be trying to find
; the case where arrays have virtual origins above 400000 in two-seg
; code. The problem is that references to the virt. origin would then
; be treated by the loader as high-seg rather than the low-seg, which is
; an obvious disaster. If the program isn't reentrant, this doesn't
; matter. Note that we want to exempt PRESET arrays from this, since they
; are supposed to be in the high segment! The remaining question is
; whether we should check PRESET arrays to be sure their virt. origin
; isn't below 400000. If so, there may be an easier test (e.g.
; consider doing XOR B,D and then testing bit 400000 or B. This would
; check that the virtual origin is in the same segment as the physical
; origin.)
SKIPE HISW ;IF REENTRANT
TRNN D,400000 ;OR NOT NEGATIVE
JRST NWORRY
SKIPGE LDYFLG ;AND PRELOADING AND
;[clh] the following used to be SKIPE.
SKIPN LDCNST ;[clh] PRESETTING
JRST .+2
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
NOREC <
GETBLK <LPSA> ;NEW BLOCK TO HOLD IT
HRLM LPSA,%TLINK(PNT) ;PTR TO BNDBLK
>;NOREC
REC <
HLRZ LPSA,%TLINK(PNT) ;GET THE BNDBLK
>;REC
MOVSI TEMP,ARYBLK ;SOURCE
HRR TEMP,LPSA ;DEST
BLT TEMP,=10-1(LPSA) ;SAVE BNDBLK INFO
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
SETZM LDCNST ;ALSO ZERO OUT LDCNST FLAG
;;#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
;;#WG# ! the record class goes here now
NOREC <
HRLM SBITS2,$ACNO(A) ;STORE NUMBER OF DIMENSIONS
>;NOREC
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
^LDYSET: SETOM LDCNST ;INDICATE PRESETTING
SKIPA ;OVER NEXT INSTRUCTION
^LDYBEG:SETZM LDCNST
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
;; \UR#1\ 11/6/76 DON'T ALLOW FLOATING POINT REPLICATIONS FOR PRELOADS
TRNN TBITS,INTEGR
ERR <NON-INTEGER REPEAT ARGUMENT>,1
;; \UR#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,DBLPRC ;DOUBLE PRECISION?
JRST LDYG2A ;NO
MOVE A,$VAL2(PNT)
PUSHJ P,CODOUT
JRST LDYG2B
LDYG2A:
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.....
LDYG2B: 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!DBLPRC ;TWICE AS MANY IF STRING OR DOUBLE
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
NOREC <
HLRZ TEMP,NUMDIM(PNT) ;#DIMENSIONS
TLNE TBITS,FORMAL ;INDEFINITE IF FORMAL
TRO TEMP,-1 ; (DON'T KNOW REAL NUMBER)
>;NOREC
REC <
JUMPE TEMP,NOBB.X ;JUST SUPERSTITION
TLNN SBITS,ARTEMP ;GET AN ARTEMP IF AN ITEMVAR OR A
TLNE TBITS,FORMAL ;FORMAL
NOBB.X: TROA TEMP,-1 ;IN WHICH CASE BNDBLK IS USELESS
;(LH =0 ALREADY)
HLRZ TEMP,NDIMSD(TEMP) ;NUMBER OF DIMS FROM BNDBLK
CAILE TEMP,5 ;THIS MAY BE ALL YOU DO WITH IT
SETZM BNDPNT(PNT2) ;BECAUSE SAIL IS A CROCK WHEN DIMS GTR 5
>;REC ;RECORD SUBFIELD
MOVEM TEMP,NUMDIM(PNT2) ;REMEMBER NUMBER OF DIMNS
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
;; #RK# (5 OF 5)AN ITEMVAR IS NOT A STRING
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING ;IF STRING ARRAY, ADJUST
JRST .+2
;; #RK#
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
NOREC <
HRRZ PNT,$VAL(PNT)
>;NOREC
REC <
HLRZ PNT,$VAL2(PNT) ;PTR AT ARRAY SEMANTICS
>;REC
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
;; \UR#26\ JRL 8-2-78 we're explicitly checking for itmvar now
;; following instructions (2) removed.
;; TRNE SP,ITMVAR
;; TRZ SP,STRING!DBLPRC
;; #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
;; \UR#26\ JRL (8-2-78)explicitly check that is not an itemvar
TRNN SP,ITMVAR
TRNN SP,STRING!DBLPRC ;STRING ARRAY?
CAIA ; NOT A STRING
;; \UR#26\
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]
;; \UR#26\ JRL - again check if itmvar explicitly
TRNN SP,ITMVAR
TRNN SP,STRING!DBLPRC
CAIA ; NOT A STRING
;; \UR#26\
PUSHJ P,EMITER ;DOUBLE INDEX
NOGT: EXCH PNT,PNT2 ;NOW PNT IS ARRAY SEMANTICS
;; #TL# ! USED TO BE A PUSHJ P,GETAD
GENMOV (ACCESS,GETD) ;GET BITS & ACCESS
;; #RE# (2 OF 2) AGAIN STRING ITEMVAR NOT STRING
;; \UR#26\ don't clobber the string bit
; TRNE TBITS,ITMVAR
; TRZ TBITS,STRING!DBLPRC
;; #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
;; \UR#26\ CHECK ITEMVAR EXPLICITLY
TRNN TBITS,ITMVAR
TRNN TBITS,STRING ;GET POINTER TO [0,0,0] WORD
CAIA
;; \UR#26\
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
REC <
HLRZ SP,$ACNO(PNT) ;REC CLASS IF APPLICABLE
>;REC
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,-1OWN ;TURN OFF MOST LH BITS
;[1] See code near RMP.RC in TOTAL for an explanation of WASIDX
TLO ARRBIT,WASIDX ;[1] BUT NOTE THAT INDXED HAS BEEN SET
MOVEM ARRBIT,$TBITS(PNT) ;THESE ARE THE REAL THING
REC <
HRLM SP,$ACNO(LPSA) ;MARK RECORD CLASS
>;REC
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
REC <
HLRZ TEMP,$ACNO(PNT) ;COPY RECD CLASS FIELD
HRLM TEMP,$ACNO(LPSA)
>;REC
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