(FILECREATED "16-Apr-86 17:15:46" {ERIS}<LISPCORE>SOURCES>LLARRAYELT.;81 95449
changes to: (FNS \PARSEARRAYSPACE)
previous date: "22-Jan-86 17:21:56" {ERIS}<LISPCORE>SOURCES>LLARRAYELT.;80)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLARRAYELTCOMS)
(RPAQQ LLARRAYELTCOMS
[(COMS (* ARRAY entries)
(FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY)
(DECLARE: DONTCOPY (MACROS ARRAYSIZE))
(FNS ELT ELTD SETA SETD SUBARRAY))
[COMS (* HASHARRAY entries)
(FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH
REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP STRINGHASHBITS)
(P (MOVD (QUOTE HARRAY)
(QUOTE GROWINGHARRAY)))
(DECLARE: DONTCOPY (EXPORT (RECORDS HARRAYP))
(RECORDS HASHSLOT)
(MACROS \FIRSTINDEX \HASHSLOT \EQHASHINGBITS \REPROBE)
(CONSTANTS (CELLSPERSLOT 2))
(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY))
(INITRECORDS HARRAYP)
(SYSRECORDS HARRAYP)
(VARS (\HASH.NULL.VALUE (QUOTE \Hash\Null\Value\]
(COMS (* System entries for CODE)
(FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR))
[COMS (* Internal)
(DECLARE: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N)
(CONSTANTS \MAXBUCKETINDEX)
(* \ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing)
(EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA
\WORDELT)))
(FNS \ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT? \MAKEFREEARRAYBLOCK
\DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD \ARRAYBLOCKMERGER
\#BLOCKDATACELLS \RECLAIMARRAYBLOCK \ADVANCE.ARRAY.SEGMENTS)
(FNS \BYTELT \BYTESETA \WORDELT)
(FNS \ARRAYTYPENAME)
(VARS (\ARRAYMERGING T))
(GLOBALVARS \ARRAYMERGING)
(COMS (* for STORAGE)
(FNS \SHOW.ARRAY.FREELISTS)
(INITVARS (\ABSTORAGETABLE NIL))
(GLOBALVARS \ABSTORAGETABLE)
(DECLARE: DONTCOPY (RECORDS SAFTABLE)))
(COMS (* Debugging and RDSYS)
(FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)
(INITVARS (ARRAYBLOCKCHECKING))
(GLOBALVARS ARRAYBLOCKCHECKING))
(P (MOVD? (QUOTE NILL)
(QUOTE \RECLAIMCODEBLOCK]
[COMS (* for MAKEINIT)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
(DECLARE: DONTCOPY (EXPORT (CONSTANTS * BLOCKGCTYPECONSTANTS)
(CONSTANTS * ARRAYCONSTANTS)
(CONSTANTS * ARRAYTYPES)
(CONSTANTS \MAX.CELLSPERHUNK)
(RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK)
(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?))
(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)
(ADDVARS (INITVALUES (\NxtArrayPage))
(INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst)
(\ArrayFrLst2))
(INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK
\ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD
\LINKBLOCK)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK))
(MKI.SUBFNS (\ALLOCBLOCK.OLD . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL)
(\HUNKING? PROGN NIL)
(\ARRAYMERGING PROGN NIL))
(EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX
FREEBLOCKCHAIN.N)
(RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
(RD.SUBFNS (EQPTR . EQUAL)
(ARRAYBLOCKCHECKING . T))
(RDPTRS (\FREEBLOCKBUCKETS))
(RDVALS (\ArrayFrLst)
(\ArrayFrLst2)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK]
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA HARRAYPROP])
(* ARRAY entries)
(DEFINEQ
(AIN
[LAMBDA (APTR INDEX N FILE) (* lmm " 5-Sep-84 12:24")
(* Reads N elements into APTR starting at INDEX.
INDEX and N are in terms of the array's indexing units)
(COND
((NOT (OR (ARRAYP APTR)
(STRINGP APTR)))
(LISPERROR "ILLEGAL ARG" APTR))
((IGREATERP 0 INDEX)
(LISPERROR "ILLEGAL ARG" INDEX))) (* note that a sequencedescriptor is either an ARRAYP or
a STRINGP)
(PROG [(OFFST (fetch (SEQUENCEDESCRIPTOR OFFST) of APTR))
(STBYTE (IDIFFERENCE INDEX (fetch (SEQUENCEDESCRIPTOR ORIG) of APTR]
(COND
((ILESSP (SELECTC (fetch (SEQUENCEDESCRIPTOR TYP) of APTR)
((LIST \ST.BYTE \ST.CODE)
(fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR))
(\ST.POS16 (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
(SETQ N (UNFOLD N BYTESPERWORD))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
(UNFOLD (fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR)
BYTESPERWORD))
((LIST \ST.INT32 \ST.FLOAT)
(SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
(SETQ N (UNFOLD N BYTESPERCELL))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
(UNFOLD (fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR)
BYTESPERCELL))
(\ST.BIT)
(LISPERROR "ILLEGAL ARG" APTR))
(IPLUS STBYTE N))
(LISPERROR "ILLEGAL ARG" APTR)))
(\BINS (\GETOFD FILE (QUOTE INPUT))
(fetch (SEQUENCEDESCRIPTOR BASE) of APTR)
(IPLUS STBYTE OFFST)
N)
(RETURN APTR])
(AOUT
[LAMBDA (APTR INDEX N FILE) (* lmm " 5-Sep-84 12:26")
(* INDEX and N are in terms of the array's indexing
unit)
(COND
((NOT (OR (ARRAYP APTR)
(STRINGP APTR)))
(LISPERROR "ILLEGAL ARG" APTR))
((IGREATERP 0 INDEX)
(LISPERROR "ILLEGAL ARG" INDEX)))
(PROG [(OFFST (fetch (SEQUENCEDESCRIPTOR OFFST) of APTR))
(STBYTE (IDIFFERENCE INDEX (fetch (SEQUENCEDESCRIPTOR ORIG) of APTR]
(* Standardize units before comparing)
(COND
((ILESSP (SELECTC (fetch (SEQUENCEDESCRIPTOR TYP) of APTR)
((LIST \ST.BYTE \ST.CODE)
(fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR))
(\ST.POS16 (SETQ N (UNFOLD N BYTESPERWORD))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
(SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
(UNFOLD (fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR)
BYTESPERWORD))
((LIST \ST.INT32 \ST.FLOAT)
(SETQ N (UNFOLD N BYTESPERCELL))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL))
(SETQ OFFST (UNFOLD OFFST BYTESPERCELL))
(UNFOLD (fetch (SEQUENCEDESCRIPTOR LENGTH) of APTR)
BYTESPERCELL))
(LISPERROR "ILLEGAL ARG" APTR))
(IPLUS STBYTE N))
(LISPERROR "ILLEGAL ARG" APTR)))
(\BOUTS (\GETOFD FILE (QUOTE OUTPUT))
(fetch (SEQUENCEDESCRIPTOR BASE) of APTR)
(IPLUS STBYTE OFFST)
N)
(RETURN APTR])
(ARRAY
(LAMBDA (SIZE TYPE INITVAL ORIG ALIGN) (* JonL "20-Sep-84 19:46")
(* extension of the normal VM definition of an array to
allow many different TYPEs, and also allows ORIG of 0)
(SETQ SIZE (FIX SIZE))
(COND
((OR (IGREATERP 0 SIZE)
(IGREATERP SIZE \MaxArrayLen))
(LISPERROR "ILLEGAL ARG" SIZE))) (* Coercefloats at outset; \ALLOCARRAY wants fixp)
(PROG (AP TYP GCTYPE (NCELLS SIZE))
(SETQ TYP (SELECTQ TYPE
(BYTE (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
\ST.BYTE)
((SMALLP SMALLPOSP WORD)
(SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
\ST.POS16)
((NIL POINTER FLAG)
(SETQ GCTYPE PTRBLOCK.GCT)
\ST.PTR)
((0 DOUBLEPOINTER) (* INTERLISP-10 style arrays--each element is 2 cells)
(SETQ NCELLS (UNFOLD SIZE 2))
(SETQ GCTYPE PTRBLOCK.GCT)
\ST.PTR2)
(FIXP \ST.INT32)
(FLOATP (COND
(INITVAL (SETQ INITVAL (FLOAT INITVAL))))
\ST.FLOAT)
(BIT (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
\ST.BIT)
(SIGNEDWORD \ST.INT32)
(COND
((EQ SIZE TYPE) (* = FIXP)
\ST.INT32)
((AND (LISTP TYPE)
(EQ (CAR TYPE)
(QUOTE BITS)))
(COND
((IGREATERP (CADR TYPE)
16)
\ST.INT32)
((IGREATERP (CADR TYPE)
8)
(SETQ NCELLS (FOLDHI SIZE WORDSPERCELL))
\ST.POS16)
((IGREATERP (CADR TYPE)
1)
(SETQ NCELLS (FOLDHI SIZE BYTESPERCELL))
\ST.BYTE)
(T (SETQ NCELLS (FOLDHI SIZE BITSPERCELL))
\ST.BIT)))
(T (\ILLEGAL.ARG TYPE)))))
(SETQ AP (create ARRAYP
TYP ← TYP
LENGTH ← SIZE
ORIG ←(SELECTQ ORIG
((0 1)
ORIG)
(NIL 1)
(LISPERROR "ILLEGAL ARG" ORIG))
OFFST ← 0
BASE ←(\ALLOCBLOCK NCELLS GCTYPE NIL ALIGN)))
(AND INITVAL
(PROG ((BASE (fetch (ARRAYP BASE) of AP))
(NWORDS (SUB1 (UNFOLD NCELLS WORDSPERCELL)))
LASTWORD2BASE)
(SETQ LASTWORD2BASE (\ADDBASE BASE (SUB1 NWORDS)))
(SELECTC TYP
(\ST.BYTE (OR (EQ 0 INITVAL)
(PROGN (\PUTBASE LASTWORD2BASE 1
(create WORD
HIBYTE ← INITVAL
LOBYTE ← INITVAL))
(\BLT BASE (\ADDBASE BASE 1)
NWORDS))))
(\ST.POS16 (OR (EQ 0 INITVAL)
(PROGN (\PUTBASE LASTWORD2BASE 1 INITVAL)
(\BLT BASE (\ADDBASE BASE 1)
NWORDS))))
(\ST.INT32 (OR (EQ 0 INITVAL)
(PROGN (\PUTBASEFIXP LASTWORD2BASE 0 INITVAL)
(\BLT BASE (\ADDBASE BASE WORDSPERCELL)
(SUB1 NWORDS)))))
((LIST \ST.PTR \ST.PTR2) (* Remove \ST.FLOAT when FLOATP is no longer stored in
PTR mode.)
(PROG ((P BASE))
(FRPTQ NCELLS (\RPLPTR P 0 INITVAL)
(SETQ P (\ADDBASE P WORDSPERCELL)))))
(\ST.FLOAT (OR (FEQP 0.0 INITVAL)
(PROGN (\PUTBASEFLOATP LASTWORD2BASE 0 INITVAL)
(\BLT BASE (\ADDBASE BASE WORDSPERCELL)
(SUB1 NWORDS)))))
(\ST.BIT (OR (EQ 0 INITVAL)
(PROGN (\PUTBASE LASTWORD2BASE 1 MASKWORD1'S)
(\BLT BASE (\ADDBASE BASE 1)
NWORDS))))
(SHOULDNT))))
(RETURN AP))))
(ARRAYSIZE
[LAMBDA (X) (* JonL " 4-NOV-83 12:44")
(\MACRO.MX (ARRAYSIZE X))])
(ARRAYTYP
[LAMBDA (ARRAY) (* rmk: "30-Dec-83 13:12")
(* This is a VM function which returns valid 2nd
argument to ARRAY)
(SELECTC (fetch (ARRAYP TYP) of (\DTEST ARRAY (QUOTE ARRAYP)))
(\ST.BYTE (QUOTE BYTE))
(\ST.PTR2 (QUOTE DOUBLEPOINTER))
(\ST.PTR (QUOTE POINTER))
(\ST.POS16 (QUOTE SMALLPOSP))
(\ST.CODE (* not valied 2nd arg to ARRAY)
(QUOTE CODE))
(\ST.INT32 (QUOTE FIXP))
(\ST.FLOAT (QUOTE FLOATP))
(\ST.BIT (QUOTE BIT))
(SHOULDNT])
(ARRAYORIG
[LAMBDA (ARRAY) (* rmk: "30-Dec-83 13:12")
(fetch (ARRAYP ORIG) of (\DTEST ARRAY (QUOTE ARRAYP])
(COPYARRAY
(LAMBDA (ARRAY) (* JonL "16-Oct-84 20:38")
(COND
((HARRAYP ARRAY)
(PROG ((NHARRAY (HASHARRAY (HARRAYSIZE ARRAY))))
(\COPYHARRAYP ARRAY NHARRAY)
(RETURN (REHASH ARRAY NHARRAY))))
(T (PROG (NEWARRAY INDEX (ORIG (ARRAYORIG ARRAY))
(TYPE (ARRAYTYP ARRAY))
(SIZE (ARRAYSIZE ARRAY)))
(SETQ NEWARRAY (ARRAY SIZE TYPE NIL ORIG))
(SETQ INDEX ORIG)
(FRPTQ SIZE (SETA NEWARRAY INDEX (ELT ARRAY INDEX))
(add INDEX 1))
(SELECTQ TYPE
((DOUBLEPOINTER)
(SETQ INDEX ORIG)
(FRPTQ SIZE (SETD NEWARRAY INDEX (ELTD ARRAY INDEX))
(add INDEX 1)))
NIL)
(RETURN NEWARRAY))))))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS ARRAYSIZE DMACRO ((A)
(ffetch (ARRAYP LENGTH)
of
(\DTEST A (QUOTE ARRAYP]
)
)
(DEFINEQ
(ELT
[LAMBDA (A N) (* lmm " 7-Jun-84 17:53")
(\DTEST A (QUOTE ARRAYP))
(PROG [(BASE (fetch (ARRAYP BASE) of A))
(N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
(COND
((OR (IGREATERP 0 N0)
(IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
(LISPERROR "ILLEGAL ARG" N)))
(SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
(RETURN (SELECTC (fetch (ARRAYP TYP) of A)
((LIST \ST.PTR \ST.PTR2)
(\GETBASEPTR (\ADDBASE2 BASE N0)
0))
(\ST.INT32 (SETQ BASE (\ADDBASE2 BASE N0))
(\MAKENUMBER (\GETBASE BASE 0)
(\GETBASE BASE 1)))
((LIST \ST.BYTE \ST.CODE)
(\GETBASEBYTE BASE N0))
(\ST.POS16 (\GETBASE BASE N0))
(\ST.BIT (LOGAND (LRSH (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
(IDIFFERENCE (SUB1 BITSPERWORD)
(IMOD N0 BITSPERWORD)))
1))
(\ST.FLOAT (\GETBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)))
(LISPERROR "ILLEGAL ARG" A])
(ELTD
[LAMBDA (A N) (* rmk: "30-Dec-83 13:13")
(\DTEST A (QUOTE ARRAYP))
(SELECTC (fetch (ARRAYP TYP) of A)
[\ST.PTR2 (PROG [(BASE (fetch (ARRAYP BASE) of A))
(N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
(COND
((OR (IGREATERP 0 N0)
(IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
(LISPERROR "ILLEGAL ARG" N)))
(SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
(RETURN (\GETBASEPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH)
of A))
N0)
0]
(ELT A N])
(SETA
[LAMBDA (A N V) (* bvm: " 6-Feb-85 15:54")
(COND
([fetch (ARRAYP READONLY) of (SETQ A (\DTEST A (QUOTE ARRAYP]
(LISPERROR "ILLEGAL ARG" A)))
(PROG [(BASE (fetch (ARRAYP BASE) of A))
(N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
(COND
((OR (ILESSP N0 0)
(IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
(LISPERROR "ILLEGAL ARG" N)))
(SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
(RETURN (SELECTC (fetch (ARRAYP TYP) of A)
((LIST \ST.PTR \ST.PTR2)
(\RPLPTR (\ADDBASE2 BASE N0)
0 V))
(\ST.INT32 (* 32-bit 2's complement integers)
(\PUTBASEFIXP (\ADDBASE2 BASE N0)
0 V))
((LIST \ST.BYTE \ST.CODE)
(\PUTBASEBYTE BASE N0 V))
(\ST.POS16 (* Unsigned 16-bit numbers)
(\PUTBASE BASE N0 V))
(\ST.BIT [\PUTBASE BASE (FOLDLO N0 BITSPERWORD)
(COND
[(EQ 0 V)
(LOGAND (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
(LOGXOR (LLSH 1 (IDIFFERENCE (SUB1
BITSPERWORD)
(IMOD N0
BITSPERWORD)))
(SUB1 (LLSH 1 BITSPERWORD]
(T (LOGOR (\GETBASE BASE (FOLDLO N0 BITSPERWORD))
(LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD)
(IMOD N0 BITSPERWORD]
V)
(\ST.FLOAT (\PUTBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL)
(FLOAT V)))
(LISPERROR "ILLEGAL ARG" A])
(SETD
[LAMBDA (A N V) (* rmk: "30-Dec-83 13:14")
(\DTEST A (QUOTE ARRAYP))
(SELECTC (fetch (ARRAYP TYP) of A)
(\ST.PTR2 (COND
((fetch (ARRAYP READONLY) of A)
(LISPERROR "ILLEGAL ARG" A)))
(PROG [(BASE (fetch (ARRAYP BASE) of A))
(N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A]
(COND
((OR (IGREATERP 0 N0)
(IGEQ N0 (fetch (ARRAYP LENGTH) of A)))
(LISPERROR "ILLEGAL ARG" N)))
(SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A)))
(\RPLPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH) of A))
N0)
0 V)
(RETURN V)))
(SETA A N V])
(SUBARRAY
[LAMBDA (X N M OLD NEWORIG) (* rmk: "30-Dec-83 13:15")
(\DTEST X (QUOTE ARRAYP))
(PROG ((LEN (fetch (ARRAYP LENGTH) of X))
(ORIG (fetch (ARRAYP ORIG) of X))
(N1 N)
(M1 M)) (* N1 and M1 so don't reset user arg)
[COND
((IGREATERP 0 N1) (* Coerce the first index)
(SETQ N1 (IPLUS N1 LEN 1]
[COND
((NULL M1) (* Now coerce the second index)
(SETQ M1 LEN))
((IGREATERP 0 M1)
(SETQ M1 (IPLUS M1 LEN 1] (* Go uninterruptable to protect the OLD~=NIL case.)
(RETURN (AND (IGEQ N1 ORIG)
(ILEQ N1 M1)
(ILEQ M1 LEN)
(UNINTERRUPTABLY
(create ARRAYP
smashing (OR (ARRAYP OLD)
(create ARRAYP))
BASE ←(fetch (ARRAYP BASE) of X)
LENGTH ←(ADD1 (IDIFFERENCE M1 N1))
TYP ←(fetch (ARRAYP TYP) of X)
OFFST ←(IDIFFERENCE (IPLUS (fetch (ARRAYP OFFST) of X)
N1)
ORIG)
ORIG ← ORIG))])
)
(* HASHARRAY entries)
(DEFINEQ
(HARRAY
[LAMBDA (MINKEYS) (* rmk: " 3-Jan-84 13:09")
(* For backward compatibility--produces a non-growing
hasharray)
(HASHARRAY MINKEYS (QUOTE ERROR])
(HASHARRAY
[LAMBDA (MINKEYS OVERFLOW HASHBITSFN EQUIVFN RECLAIMABLE REHASH-THRESHOLD)
(* bvm: "20-Jan-86 23:10")
(* MINKEYS is the number of required slots; actual number of slots is greater by the vacancy factor
REHASH-THRESHOLD default .75 -
MINKEYS is first adjusted by the vacancy factor, then bumped up to the next highest power of 2, so that hashkey can
be computed with LOGAND instead of IREMAINDER.)
[COND
((FIXP REHASH-THRESHOLD) (* Scale it)
(SETQ REHASH-THRESHOLD (AND (FIXP OVERFLOW)
(ILESSP REHASH-THRESHOLD OVERFLOW)
(FQUOTIENT REHASH-THRESHOLD OVERFLOW]
(LET ((PHYSLOTS (bind [IDEALSIZE ←(COND
(REHASH-THRESHOLD (FQUOTIENT (SUB1 MINKEYS)
REHASH-THRESHOLD))
(T (LLSH (IQUOTIENT (SUB1 MINKEYS)
3)
2]
find I from 8 by I suchthat (IGREATERP I IDEALSIZE)))
LOGSLOTS NCELLS)
(SETQ NCELLS (UNFOLD PHYSLOTS CELLSPERSLOT))
(COND
((IGREATERP NCELLS \MaxArrayNCells)
(ERROR "HARRAY TOO LARGE" MINKEYS))
(T [SETQ LOGSLOTS (COND
(REHASH-THRESHOLD (FTIMES REHASH-THRESHOLD PHYSLOTS))
(T (IPLUS (LRSH PHYSLOTS 1)
(LRSH PHYSLOTS 2] (* Number of logical slots is REHASH-THRESHOLD *
number of physical slots)
(create HARRAYP
HARRAYPBASE ←(\ALLOCBLOCK NCELLS PTRBLOCK.GCT)
LASTINDEX ←(SUB1 PHYSLOTS)
RECLAIMABLE ← RECLAIMABLE
OVERFLOWACTION ← OVERFLOW
NUMSLOTS ← LOGSLOTS
NULLSLOTS ← LOGSLOTS
NUMKEYS ← 0
HASHBITSFN ← HASHBITSFN
EQUIVFN ← EQUIVFN])
(HARRAYP
[LAMBDA (X) (* rmk: "21-Dec-83 22:20")
(AND (type? HARRAYP X)
X])
(HARRAYPROP
[LAMBDA NARGS (* bvm: "21-Jan-86 11:02")
(* Nospread so we can tell whether a new value was
specified)
(PROG ((HARRAY (AND (IGREATERP NARGS 0)
(ARG NARGS 1)))
(PROP (AND (IGREATERP NARGS 1)
(ARG NARGS 2)))
(NEWVALP (IGREATERP NARGS 2))
HA NEWVALUE)
(SETQ HA (\DTEST HARRAY (QUOTE HARRAYP)))
(* Keep HARRAY explicitly so can tell LISTP case)
(AND NEWVALP (SETQ NEWVALUE (ARG NARGS 3)))
[RETURN (SELECTQ PROP
(SIZE (AND NEWVALP (GO CANTUPDATE))
(HARRAYSIZE HA))
[OVERFLOW (COND
[(LISTP HARRAY)
(* For compatibility with old code that would enlist
the hasharray)
(PROG1 (CDR HARRAY)
(AND NEWVALP (RPLACD HARRAY NEWVALUE]
(T (PROG1 (fetch (HARRAYP OVERFLOWACTION)
of HA)
(AND NEWVALP (replace (HARRAYP
OVERFLOWACTION)
of HA with NEWVALUE]
(NUMKEYS (AND NEWVALP (GO CANTUPDATE))
(fetch (HARRAYP NUMKEYS) of HA))
[EQUIVFN (PROG1 (fetch (HARRAYP EQUIVFN) of HA)
(AND NEWVALP (COND
((NEQ (fetch (HARRAYP NUMKEYS)
of HA)
0)
(* Absurd to change equivalence relation in midstream)
(GO CANTUPDATE))
(T (replace (HARRAYP EQUIVFN)
of HA with NEWVALUE]
[RECLAIMABLE (PROG1 (fetch (HARRAYP RECLAIMABLE) of HA)
(AND NEWVALP (replace (HARRAYP
RECLAIMABLE)
of HA with NEWVALUE]
[HASHBITSFN (PROG1 (fetch (HARRAYP HASHBITSFN) of HA)
(AND NEWVALP (COND
((NEQ (fetch (HARRAYP NUMKEYS)
of HA)
0)
(GO CANTUPDATE))
(T (replace (HARRAYP HASHBITSFN)
of HA with NEWVALUE]
(PROG1 (LISTGET (SETQ HARRAY (fetch (HARRAYP HASHUSERDATA)
of HA))
PROP)
(AND NEWVALP (COND
((NULL HARRAY)
(replace (HARRAYP HASHUSERDATA)
of HA with (LIST PROP NEWVALUE)))
(T (LISTPUT HARRAY PROP NEWVALUE]
CANTUPDATE
(ERROR "Can't update this hash array property" PROP])
(HARRAYSIZE
[LAMBDA (HARRAY) (* rmk: "21-Dec-83 23:33")
(fetch NUMSLOTS of (\DTEST HARRAY (QUOTE HARRAYP])
(CLRHASH
[LAMBDA (HARRAY) (* bvm: "21-Jan-86 11:32")
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
SLOT)
(SETQ SLOT (fetch HARRAYPBASE of HA))
(UNINTERRUPTABLY
(bind [LASTSLOT ←(fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT
(fetch
(HARRAYP
LASTINDEX)
of HA]
do (replace (HASHSLOT KEY) of SLOT with NIL)
(replace (HASHSLOT VALUE) of SLOT with NIL)
repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
LASTSLOT))
(replace (HARRAYP NULLSLOTS) of HA with (fetch (HARRAYP NUMSLOTS)
of HA))
(replace (HARRAYP NUMKEYS) of HA with 0))
(RETURN HARRAY])
(MAPHASH
[LAMBDA (HARRAY MAPHFN) (* bvm: "21-Jan-86 11:28")
(DECLARE (LOCALVARS . T))
(LET ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
SLOT)
(SETQ SLOT (fetch HARRAYPBASE of HA))
(bind V [LASTSLOT ←(fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT (fetch
(HARRAYP LASTINDEX)
of HA]
(NULLVALUE ← \HASH.NULL.VALUE) when (SETQ V (fetch (HASHSLOT VALUE)
of SLOT))
do (APPLY* MAPHFN (AND (NEQ V NULLVALUE)
V)
(fetch (HASHSLOT KEY) of SLOT))
repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
LASTSLOT)
finally (RETURN HARRAY])
(GETHASH
[LAMBDA (ITEM HARRAY DEFAULT) (* bvm: "21-Jan-86 16:39")
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS EQFN ABASE VALUE)
[SETQ BITS (COND
((SETQ BITS (fetch (HARRAYP HASHBITSFN) of HA))
(APPLY* BITS ITEM))
(T (\EQHASHINGBITS ITEM]
(SETQ INDEX (\FIRSTINDEX BITS HA)) (* Do first index outside of loop, so don't have to do
setup on fast case)
(SETQ ABASE (fetch HARRAYPBASE of HA))
(SETQ SLOT (\HASHSLOT ABASE INDEX))
[COND
((SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
(* Slot is occupied)
(COND
((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
(AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
(APPLY* EQFN ITEM SKEY)))
(GO FOUND))) (* else try again)
)
((NULL (fetch (HASHSLOT KEY) of SLOT)) (* Null slot)
(RETURN DEFAULT))
(T (* Deleted slot: null value, non-nil key)
(SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
(* Perhaps we hit right on)
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS HA)) (* Compute reprobe interval)
(SETQ LIMIT (fetch (HARRAYP LASTINDEX) of HA))
LP (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE)
LIMIT)) (* Since table size is a power of two, any wraparound
in the IPLUS16 will be consistent with the LOGAND)
(COND
((EQ INDEX FIRSTINDEX) (* Should never happen, since we don't allow full
occupancy)
(RETURN NIL)))
(SETQ SLOT (\HASHSLOT ABASE INDEX))
(SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
(COND
[(SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT))
(* Slot is occupied)
(COND
((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
ITEM)
(AND EQFN (APPLY* EQFN ITEM SKEY)))
(* Found it)
(GO FOUND]
((NULL (fetch (HASHSLOT KEY) of SLOT)) (* Empty slot)
(RETURN DEFAULT)))
(GO LP)
FOUND
(RETURN (AND (NEQ VALUE \HASH.NULL.VALUE)
VALUE])
(PUTHASH
[LAMBDA (ITEM VAL HARRAY) (* bvm: "22-Jan-86 17:21")
(* * Store new value VAL, or remove old value if VAL = NIL)
(\HASHACCESS ITEM VAL HARRAY (NULL VAL))
VAL])
(REMHASH
[LAMBDA (KEY HARRAY) (* bvm: "20-Jan-86 18:54")
(\HASHACCESS KEY NIL HARRAY T])
(\HASHRECLAIM
[LAMBDA (HARRAY) (* bvm: "21-Jan-86 11:36")
(* * Remove from HARRAY any keys whose ref cnt is 1)
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
SLOT)
(SETQ SLOT (fetch (HARRAYP HARRAYPBASE) of HA))
(UNINTERRUPTABLY
(bind KEY [LASTSLOT ←(fetch (HASHSLOT NEXTSLOT)
of (\HASHSLOT SLOT (fetch (HARRAYP LASTINDEX)
of HA]
(NUMDELETED ← 0) when (AND (SETQ KEY (fetch (HASHSLOT KEY)
of SLOT))
(NEQ KEY T)
(\EQREFCNT1 KEY))
do (* Slot is occupied with key with ref cnt 1, so delete
it)
(replace (HASHSLOT KEY) of SLOT with T)
(replace (HASHSLOT VALUE) of SLOT with NIL)
(add NUMDELETED 1)
repeatuntil (EQ LASTSLOT (SETQ SLOT (fetch (HASHSLOT NEXTSLOT)
of SLOT)))
finally (replace (HARRAYP NUMKEYS) of HA
with (IDIFFERENCE (fetch (HARRAYP NUMKEYS) of HA)
NUMDELETED))))
(RETURN HARRAY])
(\HASHACCESS
[LAMBDA (ITEM VAL HARRAY REMOVE) (* bvm: "21-Jan-86 16:41")
(* * Add or remove something from hash array HARRAY -- REMOVE = T means remove the item, which is necessarily
distinct from adding a VAL = NIL)
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE)
[SETQ BITS (COND
((SETQ HASHBITSFN (fetch (HARRAYP HASHBITSFN) of HA))
(APPLY* HASHBITSFN ITEM))
(T (\EQHASHINGBITS ITEM]
PHTOP
(SETQ INDEX (\FIRSTINDEX BITS HA)) (* Handle first probe outside loop in case it wins)
(SETQ ABASE (fetch HARRAYPBASE of HA))
(SETQ SLOT (\HASHSLOT ABASE INDEX))
[COND
((fetch (HASHSLOT VALUE) of SLOT) (* Slot is occupied)
(COND
((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
(AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA))
(APPLY* EQFN ITEM SKEY)))
(GO FOUND))) (* else try again)
)
((NULL (fetch (HASHSLOT KEY) of SLOT)) (* Null slot)
(GO ADDNEWENTRY))
(T (* Deleted slot: null value, non-nil key)
(SETQ DELSLOT SLOT)
(SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA]
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS HA))
(SETQ LIMIT (fetch (HARRAYP LASTINDEX) of HA))
LP (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE)
LIMIT))
(COND
((EQ INDEX FIRSTINDEX)
(* We don't allow full occupancy, so if we get to the beginning without finding an empty slot, we must have found a
deleted one)
(SETQ SLOT (OR DELSLOT (ERROR "No vacant slot in hasharray")))
(GO ADDNEWENTRY)))
(SETQ SLOT (\HASHSLOT ABASE INDEX))
[COND
[(fetch (HASHSLOT VALUE) of SLOT) (* Slot is occupied)
(COND
((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
ITEM)
(AND EQFN (APPLY* EQFN ITEM SKEY)))
(* Found it)
(GO FOUND]
(T (COND
((NULL (fetch (HASHSLOT KEY) of SLOT))
(* NIL as both key and value means empty slot.
New entry goes here, unless there was an earlier
deleted slot)
(AND DELSLOT (SETQ SLOT DELSLOT))
(GO ADDNEWENTRY))
((NULL DELSLOT) (* Key non-NIL but value NIL means deleted.)
(SETQ DELSLOT SLOT]
(GO LP)
FOUND
(UNINTERRUPTABLY
[COND
(REMOVE (* Deleted slots are noted by value = NIL and key
non-NIL)
(replace (HASHSLOT KEY) of SLOT with T)
(replace (HASHSLOT VALUE) of SLOT with NIL)
(add (fetch (HARRAYP NUMKEYS) of HA)
-1))
(T
(* If writing value NIL must write distinguished non-NIL value. Ultimately, this should be a non-interned symbol,
so that nobody could mistakenly type it (!) but it still wouldn't be ref counted (in present world))
(replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE])
(RETURN T)
ADDNEWENTRY (* Didn't find this item in table.
If REMOVE is T, nothing to do.)
(COND
(REMOVE (RETURN NIL)))
(COND
((EQ 0 (fetch (HARRAYP NULLSLOTS) of HA))
(COND
((fetch (HARRAYP RECLAIMABLE) of HA)
(* Before rehashing, remove anything with ref cnt 1)
(\HASHRECLAIM HA)))
(SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY)))
(SETQ HA (\DTEST HARRAY (QUOTE HARRAYP)))
(* ERRORX2 doesn't handle SYSHASHARRAY specially; on 10, SYSHASHARRAY is rehashed directly in PUTHASH, without
going through ERRORX2 and independent of the normal LISTP conventions.)
(SETQ DELSLOT NIL) (* Non-NIL DELSLOT is a pointer into the old array)
(GO PHTOP)))
(UNINTERRUPTABLY
(OR (EQ SLOT DELSLOT)
(add (fetch (HARRAYP NULLSLOTS) of HA)
-1))
(add (fetch (HARRAYP NUMKEYS) of HA)
1)
(replace (HASHSLOT KEY) of SLOT with ITEM)
(replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE)))
(RETURN VAL])
(REHASH
[LAMBDA (OLDAR NEWAR) (* rmk: "26-Dec-83 11:50")
(CLRHASH NEWAR)
(PROG [SLOT LASTSLOT V (APTR1 (\DTEST OLDAR (QUOTE HARRAYP]
(* This is maphash expanded out)
(SETQ SLOT (fetch HARRAYPBASE of APTR1))
(SETQ LASTSLOT (\ADDBASE4 SLOT (fetch (HARRAYP LASTINDEX) of APTR1)))
LP (COND
((SETQ V (fetch (HASHSLOT VALUE) of SLOT))
(PUTHASH (fetch (HASHSLOT KEY) of SLOT)
V NEWAR)))
(COND
((EQ SLOT LASTSLOT)
(RETURN NEWAR)))
(SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
(GO LP])
(\COPYHARRAYP
(LAMBDA (SOURCE TARGET) (* rmk: "31-Dec-83 13:58")
(* Copies all properties of SOURCE into TARGET;
called from HASHOVERFLOW)
(replace NULLSLOTS of TARGET with (fetch NULLSLOTS of SOURCE))
(replace LASTINDEX of TARGET with (fetch LASTINDEX of SOURCE))
(replace HARRAYPBASE of TARGET with (fetch HARRAYPBASE of SOURCE))
(replace OVERFLOWACTION of TARGET with (fetch OVERFLOWACTION of SOURCE))
(replace NUMSLOTS of TARGET with (fetch NUMSLOTS of SOURCE))
(replace NUMKEYS of TARGET with (fetch NUMKEYS of SOURCE))))
(STRINGHASHBITS
[LAMBDA (STRING) (* bvm: " 6-Sep-85 10:28")
(for C inpname STRING bind (HASHBITS ← 0)
do (* This is similar to the atom hash algorithm)
[SETQ HASHBITS (IPLUS16 C (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS
(LLSH (LOGAND HASHBITS 4095)
2)))
(LLSH (LOGAND HASHBITS 255)
8]
finally (RETURN HASHBITS])
)
(MOVD (QUOTE HARRAY)
(QUOTE GROWINGHARRAY))
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE HARRAYP ((NULLSLOTS WORD) (* Number of NIL-NIL slots, which
break chains)
(LASTINDEX WORD) (* Slot offset of last slot.
Used in probe computations
computations. Microcode support for
\ADDBASE4 would help)
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG) (* True if keys can go away when no
other refs)
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD) (* The maximum number of logical
slots--returned by HARRAYSIZE)
(NUMKEYS WORD) (* The number of distinct keys in the
array)
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
]
(/DECLAREDATATYPE (QUOTE HARRAYP)
(QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER))
(QUOTE ((HARRAYP 0 (BITS . 15))
(HARRAYP 1 (BITS . 15))
(HARRAYP 2 POINTER)
(HARRAYP 2 (FLAGBITS . 0))
(HARRAYP 4 POINTER)
(HARRAYP 6 (BITS . 15))
(HARRAYP 7 (BITS . 15))
(HARRAYP 8 POINTER)
(HARRAYP 10 POINTER)
(HARRAYP 12 POINTER)))
(QUOTE 14))
(* END EXPORTED DEFINITIONS)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD HASHSLOT ((KEY POINTER)
(VALUE POINTER))
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT])
]
(DECLARE: EVAL@COMPILE
[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1)
(LOGAND BITS (fetch (HARRAYP LASTINDEX)
of APTR1]
(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4))
[PUTPROPS \EQHASHINGBITS MACRO ((X)
(* Spread out objects whose low bits are in small arithmetic
progression, esp atoms)
(LOGXOR (\HILOC X)
(LOGXOR (LLSH (LOGAND (\LOLOC X)
8191)
3)
(LRSH (\LOLOC X)
9]
(PUTPROPS \REPROBE MACRO ((BITS HA)
(LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8))
(IMIN 63 (fetch (HARRAYP LASTINDEX)
of HA)))
1)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ CELLSPERSLOT 2)
(CONSTANTS (CELLSPERSLOT 2))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY)
)
)
(/DECLAREDATATYPE (QUOTE HARRAYP)
(QUOTE (WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER))
(QUOTE ((HARRAYP 0 (BITS . 15))
(HARRAYP 1 (BITS . 15))
(HARRAYP 2 POINTER)
(HARRAYP 2 (FLAGBITS . 0))
(HARRAYP 4 POINTER)
(HARRAYP 6 (BITS . 15))
(HARRAYP 7 (BITS . 15))
(HARRAYP 8 POINTER)
(HARRAYP 10 POINTER)
(HARRAYP 12 POINTER)))
(QUOTE 14))
[ADDTOVAR SYSTEMRECLST
(DATATYPE HARRAYP ((NULLSLOTS WORD)
(LASTINDEX WORD)
(HARRAYPBASE POINTER)
(RECLAIMABLE FLAG)
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD)
(NUMKEYS WORD)
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
]
(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\)
(* System entries for CODE)
(DEFINEQ
(\CODEARRAY
[LAMBDA (NBYTES INITONPAGE) (* lmm "15-Aug-84 11:51")
(PROG NIL (* NBYTES is the number of bytes required, INITONPAGE is
the number of CELLS which must reside on same page)
(COND
((OR (IGREATERP 0 NBYTES)
(IGREATERP NBYTES 65535))
(LISPERROR "ILLEGAL ARG" NBYTES))) (* dolphin requires code blocks aligned quadword)
(RETURN (create ARRAYP
TYP ← \ST.CODE
BASE ←(\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL)
CODEBLOCK.GCT INITONPAGE CELLSPERQUAD)
LENGTH ← NBYTES
ORIG ← 0])
(\FIXCODENUM
[LAMBDA (CA BN NUM) (* rmk: "15-MAR-82 21:57")
(PROG ((BASE (fetch (ARRAYP BASE) of CA)))
(\PUTBASEBYTE BASE BN (LOGAND 255 NUM))
(\PUTBASEBYTE BASE (SETQ BN (SUB1 BN))
(LOGOR (\GETBASEBYTE BASE BN)
(LRSH NUM 8)))
(RETURN NUM])
(\FIXCODEPTR
[LAMBDA (CA BN PTR) (* lmm " 2-DEC-81 22:24")
(PROG ((BASE (fetch (ARRAYP BASE) of CA))
(LO (\LOLOC PTR)))
(UNINTERRUPTABLY
(\ADDREF PTR)
(\PUTBASEBYTE BASE BN (LOGAND LO 255))
(\PUTBASEBYTE BASE (SUB1 BN)
(LRSH LO 8))
(\PUTBASEBYTE BASE (IDIFFERENCE BN 2)
(\HILOC PTR)))
(RETURN PTR])
)
(* Internal)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS EQPTR DMACRO (= . EQ))
(PUTPROPS BUCKETINDEX MACRO ((N)
(IMIN (INTEGERLENGTH N)
\MAXBUCKETINDEX)))
[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N)
(\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N]
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXBUCKETINDEX 30)
(CONSTANTS \MAXBUCKETINDEX)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE (\ADDBASE BASE N)
N)))
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE2 (\ADDBASE2 BASE N)
N)))
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
WORDSPERCELL)))
[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J)
(\GETBASEBYTE (fetch (ARRAYP BASE)
of A)
(IPLUS (fetch (ARRAYP OFFST)
of A)
J]
(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V)
(\PUTBASEBYTE (fetch (ARRAYP BASE)
of A)
(IPLUS (fetch (ARRAYP OFFST)
of A)
J)
V)))
[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J)
[CHECK (AND (ARRAYP A)
(EQ 0 (fetch (ARRAYP ORIG)
of A))
(EQ \ST.POS16 (fetch (ARRAYP TYP)
of A]
(CHECK (IGREATERP (fetch (ARRAYP LENGTH)
of A)
J))
(\GETBASE (fetch (ARRAYP BASE)
of A)
(IPLUS (fetch (ARRAYP OFFST)
of A)
J]
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(\ALLOCBLOCK
[LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* bvm: " 7-Feb-85 15:30")
(* NCELLS is number of cells wanted not counting overhead cell. For code arrays, INITONPAGE is number of cells to be
kept on a single page. It might be necessary to flag a block with an aligned indicator, to help a compacting garbage
collector preserve the align proprty. -
Does not assume that caller is uninterruptable -
Returns NIL if NCELLS = 0 -
GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be
performed when the block is reclaimed. NIL defaults to UNBOXEDBLOCK.GCT)
(DECLARE (GLOBALVARS \ArrayFrLst))
(COND
((ILESSP NCELLS \ArrayBlockLinkingCells)
(COND
((ILESSP NCELLS 0)
(\ILLEGAL.ARG NCELLS)))
(SETQ NCELLS \ArrayBlockLinkingCells))
((IGREATERP NCELLS \MaxArrayNCells)
(\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))
(* NCELLS is number of data cells;
remember for allocation counter below)
(SELECTQ GCTYPE
(NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT))
(T (SETQ GCTYPE PTRBLOCK.GCT))
NIL) (* This SELECTQ can be removed when all callers are
upgraded to constants)
(COND
((AND INITONPAGE (OR (ILESSP INITONPAGE 0)
(IGREATERP INITONPAGE CELLSPERPAGE)))
(\ILLEGAL.ARG INITONPAGE)))
(COND
((NULL ALIGN))
((OR (ILESSP ALIGN 0)
(IGREATERP ALIGN CELLSPERPAGE))
(\ILLEGAL.ARG ALIGN))
((ILEQ ALIGN 1)
(SETQ ALIGN))
((AND INITONPAGE (PROGN (* Some check for consistency between ALIGN and
INITONPAGE is needed here)
NIL))
(ERROR "INITONPAGE and ALIGN too high")))
(OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK)
(\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN))
(PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))
ABLOCK)
RETRY
(UNINTERRUPTABLY (* Comment PPLossage)
(SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN)
(\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN)
(PROGN (FRPTQ 10 (RECLAIM))
(* * We're probably out of array space; our last chance is to collect and hope something shows up on the free list.)
(\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN))
(GO FULL))) (* ABLOCK now points to the beginning of the actual
block of storage to be used)
(replace (ARRAYBLOCK INUSE) of ABLOCK with T)
(replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of ABLOCK) with T)
(replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE)
(\CHECKARRAYBLOCK ABLOCK NIL)
(.INCREMENT.ALLOCATION.COUNT. NCELLS) (* NCELLS because CREATEREF accounts for overhead cell)
(SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords))
(\CREATEREF ABLOCK)
(RETURN ABLOCK))
FULL(LISPERROR "ARRAYS FULL" NIL T) (* User might release something, so retry.)
(GO RETRY])
(\ALLOCBLOCK.OLD
[LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (* bvm: "15-Feb-85 11:01")
(* Returns a block of the right size and alignment, or
NIL if one couldn't be found.)
(for BKTI from (BUCKETINDEX ARLEN) to \MAXBUCKETINDEX bind ABLOCK
when (AND (SETQ ABLOCK (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
0))
(bind (1STBLOCK.IN.FREECHAIN ← ABLOCK)
USABLELEN REMAINDERLEN PREFIXLEN repeatuntil (EQ (SETQ ABLOCK
(fetch (ARRAYBLOCK FWD)
of ABLOCK))
1STBLOCK.IN.FREECHAIN)
when (PROGN [COND
((OR (NEQ (fetch (ARRAYBLOCK PASSWORD) of ABLOCK)
\ArrayBlockPassword)
(NEQ (fetch (ARRAYBLOCK PASSWORD) of (fetch (ARRAYBLOCK
TRAILER)
of ABLOCK))
\ArrayBlockPassword))
(RETURN (\MP.ERROR \MP.BADARRAYBLOCK "Bad Array Block" ABLOCK]
(SETQ PREFIXLEN (COND
((OR ALIGN INITONPAGE)
(\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE ABLOCK))
(T 0)))
(IGEQ (SETQ USABLELEN (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN)
of ABLOCK)
PREFIXLEN))
ARLEN))
do (\CHECKARRAYBLOCK ABLOCK T T)
(\DELETEBLOCK? ABLOCK) (* take it off the free list)
[COND
((NEQ PREFIXLEN 0) (* We must split off a bit initially, in order to
preserve the INITONPAGE request)
(\MERGEBACKWARD (\MAKEFREEARRAYBLOCK ABLOCK PREFIXLEN))
(SETQ ABLOCK (\ADDBASE2 ABLOCK PREFIXLEN]
(SETQ REMAINDERLEN (IDIFFERENCE USABLELEN ARLEN))
(COND
[(IGREATERP REMAINDERLEN (COND
(\HUNKING? (IPLUS \MAX.CELLSPERHUNK \ArrayBlockOverheadCells))
(T 0))) (* Split off any extra space from the end of the
block.)
(\MERGEFORWARD (\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 ABLOCK ARLEN)
REMAINDERLEN]
(\HUNKING? (* Coerce the length upwards so as not to have a runt
block)
(SETQ ARLEN USABLELEN)))
(COND
((OR (NEQ PREFIXLEN 0)
(NEQ USABLELEN ARLEN)) (* If we changed the length of the block, store the new
length now)
(\MAKEFREEARRAYBLOCK ABLOCK ARLEN)))
(\CHECKARRAYBLOCK ABLOCK T)
(\CLEARCELLS (\ADDBASE ABLOCK \ArrayBlockHeaderWords)
(IDIFFERENCE ARLEN \ArrayBlockOverheadCells))
(* clear out old garbage)
(* signal that we found one)
(RETURN T)))
do (RETURN ABLOCK])
(\ALLOCBLOCK.NEW
[LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (* bvm: "12-Feb-85 19:27")
(DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage))
(* Patch up a new section of memory beginning at the end of current arrayspace, and make it a freeblock for
subsequent usage. Also used to increment to the next page/segment boundary when allocating code arrays)
(PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN)
RETRY
[COND
([AND (OR INITONPAGE ALIGN)
(NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE \ArrayFrLst]
(* Gobble up a modest amount of space in order to
insure correct alignment.)
(COND
((SETQ PREFIXLEN (\ALLOCBLOCK.NEW PREFIXLEN))
(\MERGEBACKWARD PREFIXLEN) (* Problem: what happens if array space switch happened
inside this \ALLOCBLOCK.NEW ?)
)
(T (RETURN]
(SETQ FINALWORD (\ADDBASE (\ADDBASE \ArrayFrLst ARLEN)
(SUB1 ARLEN)))
(* FINALWORD is pointer to the last word of the new block. The new \ArrayFrLst will be one past that, i.e., at
(\ADDBASE2 \ArrayFrLst ARLEN) -- The double \ADDBASE avoids large integer arithmetic and computing FINALWORD first
avoids negative arguments to \ADDBASE)
(SETQ NEXTFREEBLOCK (\ADDBASE FINALWORD 1))
[COND
((IGREATERP (SETQ FINALPAGE (fetch (POINTER PAGE#) of FINALWORD))
(IDIFFERENCE \NxtMDSPage \GUARDSTORAGEFULL))
(* Make sure that there are enough pages to satisfy
this request before we make any global changes.)
(SELECTQ (\CHECKFORSTORAGEFULL (ADD1 (IDIFFERENCE FINALPAGE \NxtArrayPage)))
(T (* Is ok, go ahead))
(0 (* Is ok, but \NxtArrayPage moved.)
(GO RETRY))
(RETURN NIL]
(* \NxtArrayPage is the page after the page of FINALWORD, the next one that needs to be \NEWPAGEd.
\ArrayFrLst's page will be (SUB1 \NxtArrayPage) except when it is allowed to be EQ to the first word on
\NxtArrayPage)
(until (IGREATERP \NxtArrayPage FINALPAGE)
do (\MAKEMDSENTRY \NxtArrayPage 0)
(\NEW2PAGE (create POINTER
PAGE# ← \NxtArrayPage))
(SETQ \NxtArrayPage (IPLUS \NxtArrayPage 2)))
(RETURN (PROG1 (\MAKEFREEARRAYBLOCK \ArrayFrLst ARLEN)
(SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK])
(\PREFIXALIGNMENT?
[LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE) (* bvm: "15-Feb-85 10:59")
(* how many cells must be added to to the base address of BASE to get a block whose first data word is aligned
according to ALIGN and which has its first INITONPAGE cells all on one page)
(PROG ((DAT (fetch (POINTER CELLINSEGMENT) of (\ADDBASE BASE \ArrayBlockHeaderWords)))
(ADJUSTMENT 0)
FUDGE)
(* DAT will hold the cell-in-segment offset of the first dataword of the arrayblock; it is this first dataword which
must be aligned etc rather than the true beginning of the block.)
LP (COND
((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN))
0)) (* Not aligned, so adjust first for that.)
(add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE)))
(add DAT FUDGE)))
(COND
((AND INITONPAGE (NEQ (FLOOR DAT CELLSPERPAGE)
(FLOOR (IPLUS DAT INITONPAGE -1)
CELLSPERPAGE))) (* There aren't INITONPAGE cells on the page, so go to
next page boundary)
[add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE CELLSPERPAGE (IMOD DAT CELLSPERPAGE]
(add DAT FUDGE)
(* * No need to realign at this point. ALIGN must be a power of two, so it's either an alignment less than
CELLSPERPAGE, in which case this page boundary satisfies it, or it's a multiple of CELLSPERPAGE, in which case the
first COND satisfied it and we didn't have to touch it in this COND)
))
(COND
([AND (EQ GCTYPE CODEBLOCK.GCT)
(IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
(SETQ FUDGE (IDIFFERENCE CELLSPERSEGMENT (SETQ DAT (IMOD DAT
CELLSPERSEGMENT]
(* Code arrays cannot cross segment boundaries.
Note that ARLEN includes the overhead cells, hence the
extra subtraction.)
(add ADJUSTMENT FUDGE)
(add DAT FUDGE)
(* * No need to re-check the alignment since ALIGN and INITONPAGE are both guaranteed satisified by a block starting
on a segment boundary)
))
(* The following code claims to prevent splitting off too small a block, but it's not clear this is intrinsically
bad, and the code does not appear to do anything rational. -- bvm -
(COND ((AND (NEQ ADJUSTMENT 0) \HUNKING? (IGREATERP (SETQ FUDGE (IDIFFERENCE (IPLUS \MAX.CELLSPERHUNK
\ArrayBlockOverheadCells) ADJUSTMENT)) 0) (PROGN (* * Account for potential merging backwards when this initial
piece is split off.) (AND (EQ (fetch (ARRAYBLOCK PASSWORD) of (SETQ PREVTRAILER (\ADDBASE BASE
(IMINUS \ArrayBlockTrailerCells)))) \ArrayBlockPassword) (NOT (fetch (ARRAYBLOCK INUSE) of PREVTRAILER))
(ILESSP (fetch (ARRAYBLOCK ARLEN) of PREVTRAILER) FUDGE)))) (* Just to ensure that we don't break up a large
arrayblocks into two pieces one of which is too small to be usable.) (add ADJUSTMENT FUDGE)
(SETQ DAT (IPLUS DAT FUDGE)) (* Go around again, since this function wouldn't have been called unless one of
INITONPAGE or ALIGN were non-null.) (GO LP))))
(RETURN ADJUSTMENT])
(\MAKEFREEARRAYBLOCK
[LAMBDA (BLOCK LENGTH) (* lmm "25-Jul-84 13:07")
(replace (ARRAYBLOCK ABFLAGS) of BLOCK with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ARLEN) of BLOCK with LENGTH)
(replace (ARRAYBLOCK ABFLAGS) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with LENGTH)
BLOCK])
(\DELETEBLOCK?
[LAMBDA (BASE) (* bvm: "15-Feb-85 11:04")
(COND
((AND (IGEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
\MinArrayBlockSize)
(fetch (ARRAYBLOCK FWD) of BASE)) (* Allegedly, BASE has been "checked" before coming
here.)
(PROG [(F (fetch (ARRAYBLOCK FWD) of BASE))
(B (fetch (ARRAYBLOCK BKWD) of BASE))
(FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE]
(COND
((EQ BASE F)
(COND
((EQ BASE (\GETBASEPTR FBL 0))
(\PUTBASEPTR FBL 0 NIL))
(T (\MP.ERROR \MP.BADDELETEBLOCK "deleting last block # FREEBLOCKLIST")))
(RETURN))
((EQ BASE (\GETBASEPTR FBL 0))
(\PUTBASEPTR FBL 0 F)))
(replace (ARRAYBLOCK BKWD) of F with B)
(replace (ARRAYBLOCK FWD) of B with F])
(\LINKBLOCK
(LAMBDA (BASE) (* JonL "16-Jan-85 02:46")
(* Add BASE to the free list.
Assumes that BASE is a well-formed free block.)
(if \FREEBLOCKBUCKETS
then (if (ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
\MinArrayBlockSize)
then (\CHECKARRAYBLOCK BASE T)
else (PROG ((FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE)))
FREEBLOCK)
(SETQ FREEBLOCK (\GETBASEPTR FBL 0))
(if (NULL FREEBLOCK)
then (replace (ARRAYBLOCK FWD) of BASE with BASE)
(replace (ARRAYBLOCK BKWD) of BASE with BASE)
else (replace (ARRAYBLOCK FWD) of BASE with FREEBLOCK)
(replace (ARRAYBLOCK BKWD) of BASE with (fetch (ARRAYBLOCK BKWD)
of FREEBLOCK))
(replace (ARRAYBLOCK FWD) of (fetch (ARRAYBLOCK BKWD) of FREEBLOCK)
with BASE)
(replace (ARRAYBLOCK BKWD) of FREEBLOCK with BASE))
(\PUTBASEPTR FBL 0 BASE)
(\CHECKARRAYBLOCK BASE T T))))
BASE))
(\MERGEBACKWARD
[LAMBDA (BASE) (* bvm: " 6-Feb-85 16:53")
(* Caller is uninterruptable and asserts that a non-NIL BASE is a free but unlinked arrayblock.
We return a linked (if possible) block, either BASE itself or an enlarged previous free block that is linked
(if possible) and includes the BASE storage.)
(PROG (ARLEN PARLEN PBASE PTRAILER SPLIT)
[COND
((NULL BASE)
(RETURN NIL))
([OR (NOT \ARRAYMERGING)
(EQ BASE \ARRAYSPACE)
(EQ BASE \ARRAYSPACE2)
(fetch (ARRAYBLOCK INUSE) of (SETQ PTRAILER (\ADDBASE BASE (IMINUS
\ArrayBlockTrailerWords]
(* If this is the absolute "first" block of array space, then there is nothing behind it to merge;
similarly, if the block behind it is in use, then don't merge.)
(RETURN (\LINKBLOCK BASE]
[SETQ PBASE (\ADDBASE2 BASE (IMINUS (fetch (ARRAYBLOCK ARLEN) of PTRAILER]
(\CHECKARRAYBLOCK PBASE T)
(\DELETEBLOCK? PBASE)
(RETURN (\ARRAYBLOCKMERGER PBASE BASE])
(\MERGEFORWARD
[LAMBDA (BASE) (* bvm: "15-Feb-85 11:18")
(* BASE is a free and linked (if possible) block. Merge with the next block if it is free and not too big.
Caller must be uninterruptable.)
(PROG (NBASE NBINUSE)
(COND
((OR (NOT \ARRAYMERGING)
(NULL BASE)
(\CHECKARRAYBLOCK BASE T T)
(EQ (SETQ NBASE (\ADDBASE2 BASE (fetch (ARRAYBLOCK ARLEN) of BASE)))
\ArrayFrLst)
(EQ NBASE \ArrayFrLst2)
[\CHECKARRAYBLOCK NBASE (NOT (SETQ NBINUSE (fetch (ARRAYBLOCK INUSE) of NBASE]
NBINUSE)
(RETURN NIL))) (* Note that if we ever get to here, both blocks have
been "checked")
(\DELETEBLOCK? NBASE)
(\DELETEBLOCK? BASE)
(\ARRAYBLOCKMERGER BASE NBASE])
(\ARRAYBLOCKMERGER
[LAMBDA (BASE NBASE) (* bvm: "13-Feb-85 14:57")
(* * BASE and NBASE are two consecutive unlinked freeblocks. (Called only after the two blocks have been "checked"))
(PROG ((ARLEN (fetch (ARRAYBLOCK ARLEN) of BASE))
(NARLEN (fetch (ARRAYBLOCK ARLEN) of NBASE))
SECONDBITE MINBLOCKSIZE SHAVEBACK)
(SETQ SECONDBITE (IDIFFERENCE \MaxArrayBlockSize ARLEN))
(COND
((IGREATERP NARLEN SECONDBITE)
(* * check if sum of NARLEN+ARLEN is leq maximum. (Written this way to stay within small number range.) If not, then
break up into two freeblocks since one can't hold all the cells.)
(SETQ ARLEN \MaxArrayBlockSize)
(SETQ NARLEN (IDIFFERENCE NARLEN SECONDBITE))
(* * Normal overflow case is just to make the first block as big as possible, then leave the rest in the second
block. So the code above adds to ARLEN and subtracts from NARLEN an equal amount to achieve the desired split.
However, check that the remaining NBASE block is not too small)
(COND
([ILESSP NARLEN (SETQ MINBLOCKSIZE (COND
(\HUNKING? (IPLUS \ArrayBlockOverheadCells \MAX.CELLSPERHUNK))
(T \MinArrayBlockSize]
(* * Decrease ARLEN and SECONDBITE by the amount it will take to get NARLEN up to MINBLOCKSIZE -- SHAVEBACK is
negative)
(SETQ SHAVEBACK (IDIFFERENCE NARLEN (SETQ NARLEN MINBLOCKSIZE)))
(add ARLEN SHAVEBACK)
(add SECONDBITE SHAVEBACK)))
(* * Okay, make a tail of the second block into a free block of its own)
(\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 NBASE SECONDBITE)
NARLEN))
(SETQ NARLEN 0)))
(RETURN (\LINKBLOCK (\MAKEFREEARRAYBLOCK BASE (IPLUS ARLEN NARLEN])
(\#BLOCKDATACELLS
(LAMBDA (DATAWORD) (* JonL "20-Sep-84 19:07")
(* DATAWORD is a pointer as would be returned by \ALLOCBLOCK Returns the number of cells available to the caller.
Compiled closed so that we can change internal representations without clients needing to be recompiled.)
(PROG ((TYPENO (NTYPX DATAWORD)))
(RETURN (if (EQ 0 TYPENO)
then (if (type? ARRAYBLOCK DATAWORD)
then (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN)
of (\ADDBASE DATAWORD (IMINUS
\ArrayBlockHeaderWords)))
\ArrayBlockOverheadCells)
else (\ILLEGAL.ARG DATAWORD))
else (OR (AND (OR \HUNKING? (fetch DTDHUNKP of (\GETDTD TYPENO)))
(HUNKSIZEFROMNUMBER TYPENO))
(\ILLEGAL.ARG DATAWORD)))))))
(\RECLAIMARRAYBLOCK
[LAMBDA (P) (* lmm "27-AUG-84 02:46")
(* This is called with interrupts turned off.)
(PROG [(B (\ADDBASE P (IMINUS \ArrayBlockHeaderWords] (* B points to arrayblock header, P to first and
subsequent data words)
(COND
((OR (NOT (IEQ \ArrayBlockPassword (fetch PASSWORD of B)))
(NOT (fetch (ARRAYBLOCK INUSE) of B))) (* RAID instead of \GCERROR because this error is
continuable with ↑N.)
(\MP.ERROR \MP.BADARRAYRECLAIM
"Bad array block reclaimed--continue with ↑N but save state ASAP")
(RETURN)))
(SELECTC (fetch (ARRAYBLOCK GCTYPE) of B)
(PTRBLOCK.GCT (for old P (TRAILER ←(fetch (ARRAYBLOCK TRAILER) of B))
by (\ADDBASE P WORDSPERCELL) until (EQ P TRAILER)
do (\RPLPTR P 0 NIL)))
(CODEBLOCK.GCT (\RECLAIMCODEBLOCK P))
NIL)
(\MERGEFORWARD (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK B (fetch ARLEN of B])
(\ADVANCE.ARRAY.SEGMENTS
[LAMBDA (NXTPAGE) (* bvm: "12-Dec-85 16:18")
(* * Called when the first 8mb are exhausted, and we want to switch array space into the next area, starting with
page NXTPAGE -- have to first clean up what's left in the old area)
(PROG (NCELLSLEFT)
(SETQ.NOREF \ArrayFrLst2 (COND
((IGEQ [SETQ NCELLSLEFT
(IPLUS (UNFOLD (SUB1 (IDIFFERENCE \NxtArrayPage
(fetch (POINTER PAGE#)
of \ArrayFrLst)))
CELLSPERPAGE)
(IDIFFERENCE CELLSPERPAGE (fetch (POINTER
CELLINPAGE)
of \ArrayFrLst]
\MinArrayBlockSize) (* Make the rest of the already allocated array space
into a small block)
(\MERGEBACKWARD (\MAKEFREEARRAYBLOCK \ArrayFrLst NCELLSLEFT))
(create POINTER
PAGE# ← \LeastMDSPage))
(T \ArrayFrLst)))
[SETQ.NOREF \ARRAYSPACE2 (SETQ.NOREF \ArrayFrLst (create POINTER
PAGE# ←(SETQ \NxtArrayPage
NXTPAGE]
(* Return code to tell \ALLOCBLOCK.NEW to notice the
new arrangement)
(RETURN 0])
)
(DEFINEQ
(\BYTELT
(LAMBDA (A J) (* JonL "20-Sep-84 20:01")
(* A special function for system accesses to 0-origin byte arrays, of which syntax-tables are the primary example.
This compiles open into a GETBASEBYTE, with no checking for argument validity!)
(OR (AND (EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A (QUOTE ARRAYP)))))
(OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
(EQ \ST.CODE (fetch (ARRAYP TYP) of A))))
(LISPERROR "ILLEGAL ARG" A))
(OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
J)
(LISPERROR "ILLEGAL ARG" J))
(\GETBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J))))
(\BYTESETA
(LAMBDA (A J V) (* JonL "20-Sep-84 20:01")
(* A special function for system setting of 0-origin byte arrays, of which syntax-tables are the primary example.
This compiles open into a GETBASEBYTE, with no checking for argument validity! -
NOTE: The value is undefined, not V!)
(OR (AND (EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A (QUOTE ARRAYP)))))
(OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A))
(EQ \ST.CODE (fetch (ARRAYP TYP) of A))))
(LISPERROR "ILLEGAL ARG" A))
(OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
J)
(LISPERROR "ILLEGAL ARG" J))
(AND (fetch (ARRAYP READONLY) of A)
(LISPERROR "ILLEGAL ARG" A))
(\PUTBASEBYTE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J)
V)))
(\WORDELT
(LAMBDA (A J) (* JonL "20-Sep-84 20:02")
(* A special function for system accesses to 0-origin
word arrays, This compiles open into a GETBASE, with no
checking for argument validity!)
(OR (AND (EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A (QUOTE ARRAYP)))))
(EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))
(LISPERROR "ILLEGAL ARG" A))
(OR (IGREATERP (fetch (ARRAYP LENGTH) of A)
J)
(LISPERROR "ILLEGAL ARG" J))
(\GETBASE (fetch (ARRAYP BASE) of A)
(IPLUS (fetch (ARRAYP OFFST) of A)
J))))
)
(DEFINEQ
(\ARRAYTYPENAME
[LAMBDA (X) (* rmk: "21-Dec-83 14:55")
(* This is called from the VM function TYPENAME to
determine the "logical" type of the array X)
(SELECTC (fetch (ARRAYP TYP) of X)
(\ST.CODE (QUOTE CCODEP))
(QUOTE ARRAYP])
)
(RPAQQ \ARRAYMERGING T)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ARRAYMERGING)
)
(* for STORAGE)
(DEFINEQ
(\SHOW.ARRAY.FREELISTS
[LAMBDA (SIZESLST) (* bvm: "12-Feb-85 15:25")
(COND
((OR SIZESLST (SETQ SIZESLST STORAGE.ARRAYSIZES))
(RESETFORM (RECLAIMMIN MAX.SMALLP)
(PROG ((TABLE \ABSTORAGETABLE)
(N (LENGTH SIZESLST))
(TOTAL 0)
FBL ABLOCK ARLEN)
[COND
((OR (NOT (\BLOCKDATAP TABLE))
(IGEQ N (FOLDLO (\#BLOCKDATACELLS TABLE)
2))) (* Need bigger table if someone has enlarged SIZESLST
since last time. There are 2 cells per table entry)
(SETQ \ABSTORAGETABLE (SETQ TABLE (\ALLOCBLOCK (UNFOLD (IPLUS N 4)
2)
UNBOXEDBLOCK.GCT]
(\CLEARCELLS TABLE (\#BLOCKDATACELLS TABLE))
[for BKTI from 0 to \MAXBUCKETINDEX
do (COND
((SETQ FBL (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI)
0))
(SETQ ABLOCK FBL)
(repeatuntil (EQ FBL (SETQ ABLOCK (fetch (ARRAYBLOCK FWD)
of ABLOCK)))
do (add TOTAL (SETQ ARLEN (fetch (ARRAYBLOCK ARLEN)
of ABLOCK)))
(for (SAFENTRY ← TABLE) by (\ADDBASE SAFENTRY
(TIMES 2 WORDSPERCELL))
as X in SIZESLST when (OR (NULL X)
(ILEQ ARLEN X))
do (add (fetch SAFITEMS of SAFENTRY)
1)
(add (fetch SAFCELLS of SAFENTRY)
ARLEN)
(RETURN]
(printout NIL T " variable-datum free list: " T)
(for (SAFENTRY ← TABLE) by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL))
as X in SIZESLST
do (COND
(X (printout NIL "le " X))
(T (printout NIL "others ")))
(printout NIL 10 .I8 (fetch SAFITEMS of SAFENTRY)
" items; " .I8 (fetch SAFCELLS of SAFENTRY)
" cells." T))
(printout NIL T "Total cells free: " .I8 TOTAL " total pages: " .I4
(FOLDHI TOTAL CELLSPERPAGE)
T T])
)
(RPAQ? \ABSTORAGETABLE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ABSTORAGETABLE)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD SAFTABLE ((SAFITEMS WORD)
(NIL WORD)
(SAFCELLS FIXP)))
]
)
(* Debugging and RDSYS)
(DEFINEQ
(\CHECKARRAYBLOCK
[LAMBDA (BASE FREE ONFREELIST) (* bvm: "13-Feb-85 14:50")
(COND
(ARRAYBLOCKCHECKING (PROG (ERROR TRAILER)
(COND
((NEQ (fetch (ARRAYBLOCK PASSWORD) of BASE)
\ArrayBlockPassword)
(SETQ ERROR "ARRAYBLOCK Password wrong"))
((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
(NOT FREE))
(SETQ ERROR "ARRAYBLOCK INUSE bit set wrong"))
((UNLESSRDSYS (AND FREE (NEQ (\REFCNT BASE)
1))
NIL)
(SETQ ERROR "Free ARRAYBLOCK with RefCnt not 1"))
((NEQ (fetch (ARRAYBLOCK PASSWORD) of (SETQ TRAILER
(fetch (ARRAYBLOCK TRAILER)
of BASE)))
\ArrayBlockPassword)
(SETQ ERROR "ARRAYBLOCK Trailer password wrong"))
((NEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
(fetch (ARRAYBLOCK ARLEN) of TRAILER))
(SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match"))
((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
(NOT FREE))
(SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong"))
((OR (NOT ONFREELIST)
(ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
\MinArrayBlockSize))
(* Remaining tests only for blocks on free list)
(RETURN))
((OR (NOT (EQPTR (fetch (ARRAYBLOCK FWD)
of (fetch (ARRAYBLOCK BKWD) of BASE))
BASE))
(NOT (EQPTR (fetch (ARRAYBLOCK BKWD)
of (fetch (ARRAYBLOCK FWD) of BASE))
BASE)))
(SETQ ERROR "ARRAYBLOCK links fouled"))
[(bind (FBL ←(FREEBLOCKCHAIN.N (fetch (ARRAYBLOCK ARLEN)
of BASE)))
ROVER first (OR (SETQ ROVER (\GETBASEPTR FBL 0))
(RETURN (SETQ ERROR
"Free block's bucket empty")))
do (AND (EQPTR ROVER BASE)
(RETURN))
(\CHECKARRAYBLOCK ROVER T)
repeatuntil (EQ (SETQ ROVER (fetch (ARRAYBLOCK FWD)
of ROVER))
(\GETBASEPTR FBL 0]
(T (* Everything ok)
(RETURN)))
(UNLESSRDSYS (\MP.ERROR \MP.BADARRAYBLOCK ERROR BASE T)
(ERROR BASE ERROR))
(RETURN ERROR])
(\PARSEARRAYSPACE
[LAMBDA (FN) (* bvm: "16-Apr-86 17:05")
(COND
((NEQ \ArrayFrLst2 \ARRAYSPACE2) (* Array space is in two chunks)
(\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst2)
(\PARSEARRAYSPACE1 FN \ARRAYSPACE2 \ArrayFrLst))
(T (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst])
(\PARSEARRAYSPACE1
[LAMBDA (FN START END) (* bvm: " 9-Jan-85 17:10")
(for (ROVER ← START) repeatuntil [EQPTR END (SETQ ROVER (\ADDBASE2 ROVER (fetch (ARRAYBLOCK
ARLEN)
of ROVER]
do (\CHECKARRAYBLOCK ROVER (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
(AND (NOT (fetch (ARRAYBLOCK INUSE) of ROVER))
(fetch (ARRAYBLOCK FWD) of ROVER)))
(AND FN (APPLY* FN ROVER (fetch (ARRAYBLOCK ARLEN) of ROVER)
(fetch (ARRAYBLOCK INUSE) of ROVER)
(fetch (ARRAYBLOCK GCTYPE) of ROVER])
)
(RPAQ? ARRAYBLOCKCHECKING )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS ARRAYBLOCKCHECKING)
)
(MOVD? (QUOTE NILL)
(QUOTE \RECLAIMCODEBLOCK))
(* for MAKEINIT)
(DEFINEQ
(PREINITARRAYS
[LAMBDA NIL (* bvm: " 9-Jan-85 16:50")
(* This is called only at the very beginning of MAKEINIT. \ARRAYspace and \ARRAYbase are INITCONSTANTS.
This sets up the array allocator so that MAKEINIT can do, e.g., string allocations.)
(DECLARE (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \NxtArrayPage))
(SETQ.NOREF \ArrayFrLst (\VAG2 \FirstArraySegment 0))
(SETQ.NOREF \ArrayFrLst2 \ARRAYSPACE2)
(SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst])
(POSTINITARRAYS
[LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (* bvm: " 7-Feb-85 15:30")
(* Called only from MAKEINIT after all code and data has been copied to the new image. AFTERCODEPTR is a pointer to
the first word after the last code byte. CODESTARTPAGE is the page at which MAKEINIT code arrays being.
This function makes sure that any unused space between the strings and the beginning of the code gets linked in as
free arrayblocks.)
(SETQ \FREEBLOCKBUCKETS (\ALLOCBLOCK (ADD1 \MAXBUCKETINDEX)))
(PROG [(EXTRACELLS (IDIFFERENCE (UNFOLD CODESTARTPAGE CELLSPERPAGE)
(IPLUS (UNFOLD (fetch SEGMENT# of \ArrayFrLst)
CELLSPERSEGMENT)
(fetch CELLINSEGMENT of \ArrayFrLst]
(* First, tell the makeiniter how many pages were left over in the string space. He may want to adjust the constants
to keep this down to just a couple of pages.)
(COND
((IGREATERP EXTRACELLS \MaxArrayBlockSize)
(printout T T T "POSTINITARRAYS: You pre-allocated too much string space." T 19
"MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about "
(IDIFFERENCE (FOLDLO EXTRACELLS CELLSPERPAGE)
10)
"." T)
(HELP))
((IGEQ EXTRACELLS \MinArrayBlockSize) (* We don't allow more than one array-block extra.)
(printout T T T "POSTINITARRAYS: There were " (FOLDLO EXTRACELLS CELLSPERPAGE)
" allocated but unused array pages." T T))
(T (printout T T "POSTINITARRAYS: String space overflowed into code-arrays" T 19
"You should add at least "
(ADD1 (FOLDLO (IMINUS EXTRACELLS)
CELLSPERPAGE))
" to MKI.CODESTARTOFFSET on MAKEINIT." T)
(HELP))) (* Cause those pages to get allocated)
(\LINKBLOCK (\ALLOCBLOCK.NEW EXTRACELLS))
(SETQ.NOREF \ArrayFrLst AFTERCODEPTR) (* \NxtArrayPage is the next page that needs to be
NEWPAGEd)
(SETQ.NOREF \NxtArrayPage CODENEXTPAGE)
(for VP from (PAGELOC \ARRAYSPACE) to (PAGELOC \NxtArrayPage) by (FOLDLO \MDSIncrement
WORDSPERPAGE)
do (\MAKEMDSENTRY VP 0])
(FILEARRAYBASE
[LAMBDA NIL (* rmk: "15-MAR-82 21:55")
(\ADDBASE \ARRAYSPACE (LOCAL (IPLUS (UNFOLD MKI.CODESTARTOFFSET WORDSPERPAGE)
(FOLDLO (IDIFFERENCE (GETFILEPTR (OUTPUT))
MKI.FirstDataByte)
BYTESPERWORD])
(FILEBLOCKTRAILER
[LAMBDA (BLOCKINFO) (* rmk: "18-NOV-82 09:49")
(* Sets up block trailer, assuming file is currently
positioned just past the last dataword)
(BOUT16 OUTX \UsedArrayFlagWord)
(BOUT16 OUTX BLOCKINFO])
(FILECODEBLOCK
(LAMBDA (NCELLS INITONPAGE) (* JonL "20-Sep-84 13:29")
(* sort of like CODEARRAY at MAKEINIT time for allocating space on the file; this code borrowed from CODEARRAY and
\ALLOCBLOCK. Returns ARLEN, which is then passed to FILEBLOCKTRAILER to set trailer length.)
(PROG (PREFIXLEN (ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)))
(* ARLEN is the number of cells in the array %.
INITONPAGE is number of cells which must reside on same
page)
(COND
((NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE CELLSPERQUAD CODEBLOCK.GCT
(FILEARRAYBASE))))
(* Check page first, cause if we did segment first and
succeeded but then failed on page, we would have to
check segment again.)
(FILEPATCHBLOCK PREFIXLEN)))
(BOUT16 OUTX \CodeArrayFlagWord)
(BOUT16 OUTX ARLEN)
(RETURN ARLEN))))
(FILEPATCHBLOCK
[LAMBDA (ARLEN) (* rmk: "18-NOV-82 09:50")
(* like \PATCHBLOCK for array allocation on files at
MAKEINIT time)
(LOCAL (BOUT16 OUTX \FreeArrayFlagWord)) (* in-use bit off , password set)
(LOCAL (BOUT16 OUTX ARLEN)) (* number of cells in this block)
[COND
((IGREATERP ARLEN \ArrayBlockHeaderCells) (* Assumes that header and trailer look alike, so that
we only need one instance for a tiny block.)
(LOCAL (BOUTZEROS (UNFOLD (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
BYTESPERCELL))) (* zeros for data words)
(LOCAL (BOUT16 OUTX \FreeArrayFlagWord)) (* Set up trailer)
(LOCAL (BOUT16 OUTX ARLEN]
NIL])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2)
(PTRBLOCK.GCT 1)
(UNBOXEDBLOCK.GCT 0)))
(DECLARE: EVAL@COMPILE
(RPAQQ CODEBLOCK.GCT 2)
(RPAQQ PTRBLOCK.GCT 1)
(RPAQQ UNBOXEDBLOCK.GCT 0)
(CONSTANTS (CODEBLOCK.GCT 2)
(PTRBLOCK.GCT 1)
(UNBOXEDBLOCK.GCT 0))
)
(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
\ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS
\ArrayBlockHeaderCells
\ArrayBlockTrailerCells
))
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords
\ArrayBlockTrailerWords))
\ArrayBlockLinkingCells
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells
\ArrayBlockLinkingCells))
(\MaxArrayBlockSize 65535)
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize
\ArrayBlockOverheadCells))
\MaxArrayLen
(\ABPASSWORDSHIFT 3)
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
1))
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1))))
(DECLARE: EVAL@COMPILE
(RPAQQ \ArrayBlockHeaderCells 1)
(RPAQQ \ArrayBlockHeaderWords 2)
(RPAQQ \ArrayBlockTrailerCells 1)
(RPAQQ \ArrayBlockTrailerWords 2)
(RPAQ \ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells))
(RPAQ \ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
(RPAQQ \ArrayBlockLinkingCells 2)
(RPAQ \MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
(RPAQQ \MaxArrayBlockSize 65535)
(RPAQ \MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
(RPAQQ \MaxArrayLen 65535)
(RPAQQ \ABPASSWORDSHIFT 3)
(RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
1))
(RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1))
(CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells
\ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells
\ArrayBlockTrailerCells))
(\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords))
\ArrayBlockLinkingCells
(\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells))
(\MaxArrayBlockSize 65535)
(\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells))
\MaxArrayLen
(\ABPASSWORDSHIFT 3)
(\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT))
(\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH UNBOXEDBLOCK.GCT 1)))
(\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
1))
(\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT)
(LLSH CODEBLOCK.GCT 1)
1)))
)
(RPAQQ ARRAYTYPES ((\ST.BYTE 0)
(\ST.POS16 1)
(\ST.INT32 2)
(\ST.CODE 4)
(\ST.PTR 6)
(\ST.FLOAT 7)
(\ST.BIT 8)
(\ST.PTR2 11)))
(DECLARE: EVAL@COMPILE
(RPAQQ \ST.BYTE 0)
(RPAQQ \ST.POS16 1)
(RPAQQ \ST.INT32 2)
(RPAQQ \ST.CODE 4)
(RPAQQ \ST.PTR 6)
(RPAQQ \ST.FLOAT 7)
(RPAQQ \ST.BIT 8)
(RPAQQ \ST.PTR2 11)
(CONSTANTS (\ST.BYTE 0)
(\ST.POS16 1)
(\ST.INT32 2)
(\ST.CODE 4)
(\ST.PTR 6)
(\ST.FLOAT 7)
(\ST.BIT 8)
(\ST.PTR2 11))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAX.CELLSPERHUNK 64)
(CONSTANTS \MAX.CELLSPERHUNK)
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1)
(NIL BITS 1)
(READONLY FLAG)
(NIL BITS 1)
(TYP BITS 4)
(BASE POINTER)
(LENGTH WORD)
(OFFST WORD)))
(DATATYPE ARRAYP ((ORIG BITS 1)
(NIL BITS 1)
(READONLY FLAG) (* probably no READONLY arrays now)
(NIL BITS 1)
(TYP BITS 4)
(BASE POINTER)
(LENGTH WORD)
(OFFST WORD)) (* note that while ARRAYP is a
DATATYPE, the allocation of it
actually happens at MAKEINIT time
under INITDATATYPE{NAMES})
)
(BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13)
(GCTYPE BITS 2) (* Unboxed, Pointers, Code, ?)
(INUSE FLAG)
(ARLEN WORD)
(FWD FULLXPOINTER) (* Only when on free list)
(BKWD FULLXPOINTER))
(BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD)
(* Used for header and trailer)
))
[ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords))
(TRAILER (\ADDBASE2 DATUM (IDIFFERENCE
(fetch (ARRAYBLOCK ARLEN)
of DATUM)
\ArrayBlockTrailerCells]
(TYPE? (AND (EQ 0 (NTYPX DATUM))
(IGEQ (\HILOC DATUM)
\FirstArraySegment))))
]
(/DECLAREDATATYPE (QUOTE ARRAYP)
(QUOTE ((BITS 1)
(BITS 1)
FLAG
(BITS 1)
(BITS 4)
POINTER WORD WORD))
[QUOTE ((ARRAYP 0 (BITS . 0))
(ARRAYP 0 (BITS . 16))
(ARRAYP 0 (FLAGBITS . 32))
(ARRAYP 0 (BITS . 48))
(ARRAYP 0 (BITS . 67))
(ARRAYP 0 POINTER)
(ARRAYP 2 (BITS . 15))
(ARRAYP 3 (BITS . 15]
(QUOTE 4))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)
)
(ADDTOVAR INITVALUES (\NxtArrayPage))
(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst)
(\ArrayFrLst2))
(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \ALLOCBLOCK.NEW
\MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK)
(FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK))
(ADDTOVAR MKI.SUBFNS (\ALLOCBLOCK.OLD . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL)
(\HUNKING? PROGN NIL)
(\ARRAYMERGING PROGN NIL))
(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N)
(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1))
(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL)
(ARRAYBLOCKCHECKING . T))
(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
(ADDTOVAR RDVALS (\ArrayFrLst)
(\ArrayFrLst2))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA HARRAYPROP)
)
(PUTPROPS LLARRAYELT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5589 14529 (AIN 5599 . 7242) (AOUT 7244 . 8825) (ARRAY 8827 . 12676) (ARRAYSIZE 12678
. 12820) (ARRAYTYP 12822 . 13516) (ARRAYORIG 13518 . 13694) (COPYARRAY 13696 . 14527)) (14760 20260 (
ELT 14770 . 15832) (ELTD 15834 . 16494) (SETA 16496 . 18258) (SETD 18260 . 19016) (SUBARRAY 19018 .
20258)) (20291 38637 (HARRAY 20301 . 20593) (HASHARRAY 20595 . 22401) (HARRAYP 22403 . 22544) (
HARRAYPROP 22546 . 25388) (HARRAYSIZE 25390 . 25564) (CLRHASH 25566 . 26442) (MAPHASH 26444 . 27237) (
GETHASH 27239 . 29983) (PUTHASH 29985 . 30229) (REMHASH 30231 . 30375) (\HASHRECLAIM 30377 . 31613) (
\HASHACCESS 31615 . 36561) (REHASH 36563 . 37304) (\COPYHARRAYP 37306 . 38102) (STRINGHASHBITS 38104
. 38635)) (43091 44563 (\CODEARRAY 43101 . 43781) (\FIXCODENUM 43783 . 44127) (\FIXCODEPTR 44129 .
44561)) (47223 70308 (\ALLOCBLOCK 47233 . 50704) (\ALLOCBLOCK.OLD 50706 . 53786) (\ALLOCBLOCK.NEW
53788 . 56563) (\PREFIXALIGNMENT? 56565 . 60008) (\MAKEFREEARRAYBLOCK 60010 . 60509) (\DELETEBLOCK?
60511 . 61491) (\LINKBLOCK 61493 . 62778) (\MERGEBACKWARD 62780 . 63987) (\MERGEFORWARD 63989 . 64932)
(\ARRAYBLOCKMERGER 64934 . 66900) (\#BLOCKDATACELLS 66902 . 67823) (\RECLAIMARRAYBLOCK 67825 . 68978)
(\ADVANCE.ARRAY.SEGMENTS 68980 . 70306)) (70309 72947 (\BYTELT 70319 . 71159) (\BYTESETA 71161 .
72145) (\WORDELT 72147 . 72945)) (72948 73350 (\ARRAYTYPENAME 72958 . 73348)) (73468 75672 (
\SHOW.ARRAY.FREELISTS 73478 . 75670)) (75971 79660 (\CHECKARRAYBLOCK 75981 . 78550) (\PARSEARRAYSPACE
78552 . 78960) (\PARSEARRAYSPACE1 78962 . 79658)) (79842 85473 (PREINITARRAYS 79852 . 80407) (
POSTINITARRAYS 80409 . 82756) (FILEARRAYBASE 82758 . 83050) (FILEBLOCKTRAILER 83052 . 83406) (
FILECODEBLOCK 83408 . 84569) (FILEPATCHBLOCK 84571 . 85471)))))
STOP