(FILECREATED " 7-Sep-85 00:17:51" {ERIS}<LISPCORE>SOURCES>LLARRAYELT.;75 85107
changes to: (FNS PUTHASH)
previous date: " 6-Sep-85 10:42:17" {ERIS}<LISPCORE>SOURCES>LLARRAYELT.;74)
(* Copyright (c) 1982, 1983, 1984, 1985 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 CLRHASH GETHASH HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE MAPHASH PUTHASH
REHASH \COPYHARRAYP STRINGHASHBITS)
(P (MOVD (QUOTE HARRAY)
(QUOTE GROWINGHARRAY)))
(DECLARE: DONTCOPY (EXPORT (RECORDS HARRAYP))
(RECORDS HASHINDEX HASHSLOT)
(MACROS \FIRSTINDEX \HASHINGBITS \REPROBE \NEWREPROBE)
(CONSTANTS (CELLSPERSLOT 2)))
(INITRECORDS HARRAYP)
(SYSRECORDS HARRAYP)
(EXPORT (GLOBALVARS SYSHASHARRAY)))
(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
(CLRHASH
[LAMBDA (HARRAY) (* rmk: "31-Dec-83 13:58")
(PROG [SLOT (APTR1 (\DTEST HARRAY (QUOTE HARRAYP]
(SETQ SLOT (fetch HARRAYPBASE of APTR1))
(UNINTERRUPTABLY
(FRPTQ (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1))
(\RPLPTR SLOT 0 NIL)
(\RPLPTR SLOT WORDSPERCELL NIL)
(SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT)))
(replace NULLSLOTS of APTR1 with (fetch NUMSLOTS of APTR1))
(replace NUMKEYS of APTR1 with 0))
(RETURN HARRAY])
(GETHASH
[LAMBDA (ITEM HARRAY) (* bvm: " 7-Feb-85 21:47")
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE)
[SETQ BITS (COND
((SETQ HASHBITSFN (fetch HASHBITSFN of HA))
(APPLY* HASHBITSFN ITEM))
(T (\HASHINGBITS ITEM]
(SETQ ABASE (fetch HARRAYPBASE of HA)) (* ABASE is used by HASHINDEX fields)
(SETQ INDEX (\FIRSTINDEX BITS HA)) (* Do first index outside of loop, so don't have to do
setup on fast case)
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
(COND
((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
(AND (SETQ EQFN (fetch EQUIVFN of HA))
(APPLY* EQFN ITEM SKEY)))
(RETURN (fetch (HASHSLOT VALUE) of SLOT)))
((AND (NULL SKEY)
(NULL (fetch (HASHSLOT VALUE) of SLOT))) (* Empty slot)
(RETURN NIL))) (* Perhaps we hit right on)
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS HA)) (* Compute reprobe interval)
(SETQ LIMIT (IDIFFERENCE (ADD1 (fetch (HARRAYP LASTINDEX) of HA))
REPROBE)) (* Test on difference before adding to avoid landing
outside of smallps)
LP [SETQ INDEX (COND
((IGEQ INDEX LIMIT) (* Wrap around)
(IDIFFERENCE INDEX LIMIT))
(T (IPLUS INDEX REPROBE]
(* If LASTINDEX is guaranteed to be (SUB1 2↑N) we can speed this up a smidge by doing (LOGAND
(IPLUS INDEX REPROBE) LASTINDEX), instead of testing.)
(COND
((EQ INDEX FIRSTINDEX)
(RETURN NIL)))
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
(SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
(COND
((OR (EQ SKEY ITEM)
(AND EQFN (APPLY* EQFN ITEM SKEY)))
(RETURN (fetch (HASHSLOT VALUE) of SLOT)))
((AND (NULL SKEY)
(NULL (fetch (HASHSLOT VALUE) of SLOT))) (* Empty slot)
(RETURN)))
(GO LP])
(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) (* JonL " 6-Jan-85 03:06")
(* MINKEYS is the number of required slots; actual number of slots is greater by the vacancy factor
(currently 5/8) -
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.)
(PROG (NCELLS LOGSLOTS (PHYSLOTS (find I (L ←(LLSH (IQUOTIENT (SUB1 MINKEYS)
5)
3))
from 8 by I suchthat (IGREATERP I L))))
(SETQ NCELLS (UNFOLD PHYSLOTS CELLSPERSLOT))
(if (IGREATERP NCELLS \MaxArrayNCells)
then (ERROR "HARRAY TOO LARGE" MINKEYS))
(SETQ LOGSLOTS (IPLUS (LRSH PHYSLOTS 1)
(LRSH PHYSLOTS 3)))
(RETURN (create HARRAYP
HARRAYPBASE ←(\ALLOCBLOCK NCELLS PTRBLOCK.GCT)
LASTINDEX ←(SUB1 PHYSLOTS)
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: " 6-Sep-85 10:38")
(* 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]
[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])
(MAPHASH
[LAMBDA (HARRAY MAPHFN) (* rmk: "26-Dec-83 11:51")
(DECLARE (LOCALVARS . T))
(PROG [SLOT LASTSLOT V (APTR1 (\DTEST HARRAY (QUOTE HARRAYP]
(* This is the 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))
(APPLY* MAPHFN V (fetch (HASHSLOT KEY) of SLOT]
(COND
((EQ SLOT LASTSLOT)
(RETURN HARRAY)))
(SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
(GO LP])
(PUTHASH
[LAMBDA (ITEM VAL HARRAY) (* lmm " 7-Sep-85 00:13")
(PROG ((HA (\DTEST HARRAY (QUOTE HARRAYP)))
DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE OLDVAL)
[SETQ BITS (COND
((SETQ HASHBITSFN (fetch HASHBITSFN of HA))
(APPLY* HASHBITSFN ITEM))
(T (\HASHINGBITS ITEM]
PHTOP
(SETQ ABASE (fetch HARRAYPBASE of HA)) (* ABASE is used by HASHINDEX fields)
(SETQ INDEX (\FIRSTINDEX BITS HA))
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
(SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
(SETQ OLDVAL (FETCH (HASHSLOT VALUE) OF SLOT))
(if OLDVAL
then (if (OR (EQ ITEM SKEY)
(AND (SETQ EQFN (fetch EQUIVFN of HA))
(APPLY* EQFN ITEM SKEY)))
then (GO FOUND)) (* else try again)
elseif (NULL SKEY)
then (* Null slot)
(GO ITEMENTRY)
else (* Deleted slot: null value, non-nil key)
(SETQ DELSLOT SLOT))
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS HA))
(SETQ LIMIT (IDIFFERENCE (ADD1 (fetch (HARRAYP LASTINDEX) of HA))
REPROBE))
LP [SETQ INDEX (COND
((IGEQ INDEX LIMIT)
(IDIFFERENCE INDEX LIMIT))
(T (IPLUS INDEX REPROBE]
(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 ITEMENTRY)))
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
(SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))
(SETQ OLDVAL (FETCH (HASHSLOT VALUE) OF SLOT))
[IF OLDVAL
THEN (COND
((OR (EQ SKEY ITEM)
(AND EQFN (APPLY* EQFN ITEM SKEY)))
(* Found it)
(GO FOUND))
((AND (NULL DELSLOT)
(NULL (fetch (HASHSLOT VALUE) of SLOT)))
(* Key non-NIL but value NIL means deleted.)
(SETQ DELSLOT SLOT)))
ELSE (COND
((NULL SKEY) (* NIL as a key and value means empty slot)
(AND DELSLOT (SETQ SLOT DELSLOT))
(GO ITEMENTRY))
((NULL DELSLOT) (* Key non-NIL but value NIL means deleted.)
(SETQ DELSLOT SLOT]
(GO LP)
FOUND
(UNINTERRUPTABLY
(COND
((NULL VAL)
(replace (HASHSLOT KEY) of SLOT with T) (* Unique string means we will never match a deleted
slot)
(add (fetch NUMKEYS of HA)
-1)))
(replace (HASHSLOT VALUE) of SLOT with VAL))
(RETURN VAL)
ITEMENTRY (* Didn't find this item in table.
If VAL is NIL, nothing to do.)
(COND
((NULL VAL)
(RETURN)))
(COND
((EQ 0 (fetch NULLSLOTS of 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 NULLSLOTS of HA)
-1))
(add (fetch NUMKEYS of HA)
1)
(replace (HASHSLOT KEY) of SLOT with ITEM)
(replace (HASHSLOT VALUE) of SLOT with VAL))
(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)
(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 POINTER WORD WORD POINTER POINTER POINTER))
(QUOTE ((HARRAYP 0 (BITS . 15))
(HARRAYP 1 (BITS . 15))
(HARRAYP 2 POINTER)
(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
(ACCESSFNS HASHINDEX ((KEY (fetch (HASHSLOT KEY) of (fetch (HASHINDEX HASHSLOT) of DATUM))
(replace (HASHSLOT KEY) of (fetch (HASHINDEX HASHSLOT) of DATUM)
NEWVALUE))
(VALUE (fetch (HASHSLOT VALUE) of (fetch (HASHINDEX HASHSLOT) of DATUM))
(replace (HASHSLOT VALUE) of (fetch (HASHINDEX HASHSLOT) of DATUM)
NEWVALUE))
(HASHSLOT (\ADDBASE4 ABASE DATUM))
(NEXTINDEX (IPLUS DATUM 1))))
(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 \HASHINGBITS MACRO ((ITEM)
(LOGXOR (\LOLOC ITEM)
(\HILOC ITEM]
(PUTPROPS \REPROBE MACRO ((BITS APTR)
1))
[PUTPROPS \NEWREPROBE MACRO ((BITS APTR)
(ADD1 (UNFOLD (LOGAND BITS (FOLDLO (fetch (HARRAYP LASTINDEX)
of APTR)
2))
2]
)
(DECLARE: EVAL@COMPILE
(RPAQQ CELLSPERSLOT 2)
(CONSTANTS (CELLSPERSLOT 2))
)
)
(/DECLAREDATATYPE (QUOTE HARRAYP)
(QUOTE (WORD WORD POINTER POINTER WORD WORD POINTER POINTER POINTER))
(QUOTE ((HARRAYP 0 (BITS . 15))
(HARRAYP 1 (BITS . 15))
(HARRAYP 2 POINTER)
(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)
(OVERFLOWACTION POINTER)
(NUMSLOTS WORD)
(NUMKEYS WORD)
(HASHBITSFN POINTER)
(EQUIVFN POINTER)
(HASHUSERDATA POINTER)))
]
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SYSHASHARRAY)
)
(* END EXPORTED DEFINITIONS)
(* 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: "15-Jan-85 22:31")
(* * 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 \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: " 9-Jan-85 17:10")
(COND
((NEQ 0 (fetch (IFPAGE FullSpaceUsed) of \InterfacePage))
(* 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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3951 12891 (AIN 3961 . 5604) (AOUT 5606 . 7187) (ARRAY 7189 . 11038) (ARRAYSIZE 11040
. 11182) (ARRAYTYP 11184 . 11878) (ARRAYORIG 11880 . 12056) (COPYARRAY 12058 . 12889)) (13038 18538 (
ELT 13048 . 14110) (ELTD 14112 . 14772) (SETA 14774 . 16536) (SETD 16538 . 17294) (SUBARRAY 17296 .
18536)) (18569 33105 (CLRHASH 18579 . 19203) (GETHASH 19205 . 21661) (HARRAY 21663 . 21955) (HASHARRAY
21957 . 23129) (HARRAYP 23131 . 23272) (HARRAYPROP 23274 . 25635) (HARRAYSIZE 25637 . 25811) (MAPHASH
25813 . 26559) (PUTHASH 26561 . 31029) (REHASH 31031 . 31772) (\COPYHARRAYP 31774 . 32570) (
STRINGHASHBITS 32572 . 33103)) (36332 37804 (\CODEARRAY 36342 . 37022) (\FIXCODENUM 37024 . 37368) (
\FIXCODEPTR 37370 . 37802)) (39340 62400 (\ALLOCBLOCK 39350 . 42821) (\ALLOCBLOCK.OLD 42823 . 45903) (
\ALLOCBLOCK.NEW 45905 . 48680) (\PREFIXALIGNMENT? 48682 . 52125) (\MAKEFREEARRAYBLOCK 52127 . 52626) (
\DELETEBLOCK? 52628 . 53608) (\LINKBLOCK 53610 . 54895) (\MERGEBACKWARD 54897 . 56104) (\MERGEFORWARD
56106 . 57049) (\ARRAYBLOCKMERGER 57051 . 59017) (\#BLOCKDATACELLS 59019 . 59940) (\RECLAIMARRAYBLOCK
59942 . 61095) (\ADVANCE.ARRAY.SEGMENTS 61097 . 62398)) (62401 65039 (\BYTELT 62411 . 63251) (
\BYTESETA 63253 . 64237) (\WORDELT 64239 . 65037)) (65040 65442 (\ARRAYTYPENAME 65050 . 65440)) (65560
67764 (\SHOW.ARRAY.FREELISTS 65570 . 67762)) (68035 71785 (\CHECKARRAYBLOCK 68045 . 70614) (
\PARSEARRAYSPACE 70616 . 71085) (\PARSEARRAYSPACE1 71087 . 71783)) (71967 77598 (PREINITARRAYS 71977
. 72532) (POSTINITARRAYS 72534 . 74881) (FILEARRAYBASE 74883 . 75175) (FILEBLOCKTRAILER 75177 . 75531
) (FILECODEBLOCK 75533 . 76694) (FILEPATCHBLOCK 76696 . 77596)))))
STOP