(FILECREATED " 5-JUL-83 14:31:31" {PHYLUM}<LISPCORE>SOURCES>LLARRAYELT.;40 67581
changes to: (MACROS \REPROBE)
(FNS GETHASH PUTHASH)
previous date: " 6-JUN-83 05:45:45" {PHYLUM}<LISPCORE>ARRAYS>LLARRAYELT.;17)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT LLARRAYELTCOMS)
(RPAQQ LLARRAYELTCOMS ((* code for arrays/strings)
(FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY ALLOCSTRING)
(FNS ELT ELTD SETA SETD SUBARRAY)
(COMS (* Hash arrays)
(FNS CLRHASH GETHASH HARRAY HARRAYP HARRAYSIZE MAPHASH PUTHASH REHASH
\HASHVACANCIES)
(DECLARE: DONTCOPY (RECORDS HASHINDEX HASHSLOT POSTSLOT)
(MACROS \FIRSTINDEX \HASHINGBITS \REPROBE))
(EXPORT (GLOBALVARS SYSHASHARRAY)))
(COMS (* System entries for compiled code blocks)
(FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR))
[COMS (* Private entries)
(FNS \ARRAYTYPENAME \ALLOCBLOCK \ALLOCNEWBLOCK \ALLOCOLDBLOCK)
(* Functions for managing array garbage.)
(FNS \DELETEBLOCK \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD \PATCHBLOCK
\RECLAIMARRAYBLOCK)
(FNS \BYTELT \BYTESETA \WORDELT)
(FNS \GETBASESTRING \PUTBASESTRING)
(* \ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing)
(DECLARE: DONTCOPY (EXPORT (MACROS \#BLOCKDATACELLS \ADDBASE2 \ADDBASE4
\BYTELT \BYTESETA \WORDELT]
(* for MAKEINIT)
(FNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK)
(DECLARE: DONTCOPY (EXPORT (CONSTANTS * BLOCKGCTYPECONSTANTS)
(CONSTANTS * ARRAYCONSTANTS)
(CONSTANTS * ARRAYTYPES)
(RECORDS SEQUENCEDESCRIPTOR ARRAYP STRINGP
ARRAYBLOCK))
(GLOBALVARS \NxtArrayPage \FREEBLOCKLIST \ArrayFrLst)
(* for MAKEINIT)
(ADDVARS (INITVALUES (\NxtArrayPage))
(INITPTRS (\FREEBLOCKLIST)
(\ArrayFrLst))
(INEWCOMS (FNS ALLOCSTRING \ALLOCBLOCK \ALLOCNEWBLOCK
\LINKBLOCK \MERGEBACKWARD \PATCHBLOCK)
(FNS COPYSTRING PREINITARRAYS POSTINITARRAYS
FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK))
(MKI.SUBFNS (\ALLOCOLDBLOCK . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR))
(EXPANDMACROFNS \#BLOCKDATACELLS \ADDBASE2 \ADDBASE4))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS COPYSTRING PREINITARRAYS POSTINITARRAYS
FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK)))
(LOCALVARS . T)))
(* code for arrays/strings)
(DEFINEQ
(AIN
[LAMBDA (APTR INDEX N FILE) (* edited: "11-DEC-82 20:25")
(* 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)))
(PROG [(OFFST (fetch (ARRAYP OFFST) of APTR))
(STBYTE (IDIFFERENCE INDEX (fetch (ARRAYP ORIG) of APTR]
(COND
((ILESSP (SELECTC (fetch (ARRAYP TYP) of APTR)
((LIST \ST.BYTE \ST.CODE)
(fetch (ARRAYP LENGTH) of APTR))
(\ST.POS16 (SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
(SETQ N (UNFOLD N BYTESPERWORD))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
(UNFOLD (fetch (ARRAYP 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 (ARRAYP LENGTH) of APTR)
BYTESPERCELL))
(\ST.BIT)
(LISPERROR "ILLEGAL ARG" APTR))
(IPLUS STBYTE N))
(LISPERROR "ILLEGAL ARG" APTR)))
(\BINS (\GETOFD FILE (QUOTE INPUT))
(fetch (ARRAYP BASE) of APTR)
(IPLUS STBYTE OFFST)
N)
(RETURN APTR])
(AOUT
[LAMBDA (APTR INDEX N FILE) (* rmk: " 2-NOV-82 13:37")
(* 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 (ARRAYP OFFST) of APTR))
(STBYTE (IDIFFERENCE INDEX (fetch (ARRAYP ORIG) of APTR]
(* Standardize units before comparing)
(COND
((ILESSP (SELECTC (fetch (ARRAYP TYP) of APTR)
((LIST \ST.BYTE \ST.CODE)
(fetch (ARRAYP LENGTH) of APTR))
(\ST.POS16 (SETQ N (UNFOLD N BYTESPERWORD))
(SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD))
(SETQ OFFST (UNFOLD OFFST BYTESPERWORD))
(UNFOLD (fetch (ARRAYP 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 (ARRAYP LENGTH) of APTR)
BYTESPERCELL))
(LISPERROR "ILLEGAL ARG" APTR))
(IPLUS STBYTE N))
(LISPERROR "ILLEGAL ARG" APTR)))
(\BOUTS (\GETOFD FILE (QUOTE OUTPUT))
(fetch (ARRAYP BASE) of APTR)
(IPLUS STBYTE OFFST)
N)
(RETURN APTR])
(ARRAY
[LAMBDA (SIZE TYPE INITVAL ORIG) (* edited: "31-MAY-83 09:37")
(* 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)
((POINTER FLAG)
(SETQ GCTYPE PTRBLOCK.GCT)
\ST.PTR)
((NIL 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)))
(T (* Coerce to 0.0 as long as FLOATP is stored in PTR
mode.)
(SETQ INITVAL 0.0)))
(SETQ GCTYPE PTRBLOCK.GCT)
\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)))
[AND INITVAL (PROG ((BASE (fetch (ARRAYP BASE) of AP)))
(SELECTC TYP
[\ST.BYTE (OR (ZEROP INITVAL)
(for I from 0 to (SUB1 SIZE)
do (\PUTBASEBYTE BASE I INITVAL]
[\ST.POS16 (OR (ZEROP INITVAL)
(for I from 0 to (SUB1 SIZE)
do (\PUTBASE BASE I INITVAL]
[\ST.INT32 (OR (ZEROP INITVAL)
(PROG ((P BASE))
(FRPTQ NCELLS (PutUnboxed P INITVAL)
(SETQ P (\ADDBASE P WORDSPERCELL]
[(LIST \ST.PTR \ST.PTR2 \ST.FLOAT)
(* 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 (* INITVAL is coerced to FLOAT in the TYPE SELECTQ)
(OR (FEQP 0.0 INITVAL)
(PROG ((P BASE))
(FRPTQ NCELLS (PutFloat P INITVAL)
(SETQ P (\ADDBASE P WORDSPERCELL]
[\ST.BIT (OR (ZEROP INITVAL)
(PROG ((P BASE))
(FRPTQ NCELLS (\PUTBASE P 0 65535)
(\PUTBASE P 1 65535)
(SETQ P (\ADDBASE P WORDSPERCELL]
(SHOULDNT]
(RETURN AP])
(ARRAYSIZE
[LAMBDA (X) (* edited: "11-DEC-82 20:17")
(COND
((ARRAYP X)
(IDIFFERENCE (fetch (ARRAYP LENGTH) of X)
(fetch (ARRAYP OFFST) of X)))
(T (LISPERROR "ARG NOT ARRAY" X])
(ARRAYTYP
[LAMBDA (ARRAY) (* rmk: " 2-JAN-83 22:44")
(* This is a VM function which returns valid 2nd
argument to ARRAY)
(SELECTC (fetch (ARRAYP TYP) of (OR (ARRAYP ARRAY)
(LISPERROR "ARG NOT ARRAY" ARRAY)))
(\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.HASH (QUOTE HARRAYP))
(\ST.FLOAT (QUOTE FLOATP))
(\ST.BIT (QUOTE BIT))
(SHOULDNT])
(ARRAYORIG
[LAMBDA (ARRAY) (* lmm "27-JUN-80 23:09")
(fetch (ARRAYP ORIG) of (OR (ARRAYP ARRAY)
(LISPERROR "ARG NOT ARRAY" ARRAY])
(COPYARRAY
[LAMBDA (ARRAY) (* rmk: "30-DEC-82 12:45")
(COND
[(HARRAYP ARRAY)
(REHASH ARRAY (HARRAY (HARRAYSIZE ARRAY]
(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])
(ALLOCSTRING
[LAMBDA (N INITCHAR OLD) (* rrb "13-DEC-82 11:19")
(SETQ N (FIX N)) (* Coerce floats at the outset)
(COND
((OR (ILESSP N 0)
(IGREATERP N \MaxArrayLen))
(LISPERROR "ILLEGAL ARG" N)))
[PROG [(B (\ALLOCBLOCK (FOLDHI N BYTESPERCELL] (* Allocate the block before going uninterruptable in
the smashing case.)
(COND
((STRINGP OLD)
(UNINTERRUPTABLY
(create STRINGP smashing OLD LENGTH ← N BASE ← B)))
(T (SETQ OLD (create STRINGP
LENGTH ← N
BASE ← B] (* INITCHAR=NIL means don't care;
\ALLOCBLOCK always zeros the block, so don't need to
initialize there either)
[COND
([AND INITCHAR (NEQ 0 (SETQ INITCHAR (LOGAND (OR (SMALLP INITCHAR)
(CHCON1 INITCHAR))
\CHARMASK]
(for I (OBASE ←(ffetch (STRINGP BASE) of OLD)) from 0 to (SUB1 N)
do (\PUTBASEBYTE OBASE I INITCHAR]
OLD])
)
(DEFINEQ
(ELT
[LAMBDA (A N) (* rmk: " 2-JAN-83 22:38")
(COND
((NOT (ARRAYP 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)))
(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 (* Currently implement FLOAT as PTR, to avoid boxing on
fetching.)
(* (SETQ BASE (\ADDBASE2 BASE N0))
(MAKEFLOATNUMBER (\GETBASE BASE 0)
(\GETBASE BASE 1)))
(\GETBASEPTR (\ADDBASE2 BASE N0)
0))
(LISPERROR "ILLEGAL ARG" A])
(ELTD
[LAMBDA (A N) (* rmk: "30-MAR-83 10:35")
(SELECTC (AND (ARRAYP A)
(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) (* edited: "31-MAY-83 18:38")
(COND
((NULL (ARRAYP A))
(LISPERROR "ILLEGAL ARG" A))
((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)))
(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)
(PutUnboxed (\ADDBASE2 BASE N0)
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
[(ZEROP 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 (* Currently implement FLOAT as PTR, to avoid boxing on
fetching.)
(* (PutFloat (\ADDBASE2 BASE N0) V))
(\RPLPTR (\ADDBASE2 BASE N0)
0
(FLOAT V)))
(LISPERROR "ILLEGAL ARG" A])
(SETD
[LAMBDA (A N V) (* rmk: " 1-JAN-83 11:50")
(SELECTC (AND (ARRAYP A)
(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: "29-DEC-82 16:01")
(OR (ARRAYP X)
(LISPERROR "ARG NOT ARRAY" X))
(AND (EQ \ST.HASH (fetch (ARRAYP TYP) of X))
(\ILLEGAL.ARG X))
(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))])
)
(* Hash arrays)
(DEFINEQ
(CLRHASH
[LAMBDA (HARRAY) (* lmm "13-OCT-82 10:10")
(PROG ((APTR1 (OR HARRAY SYSHASHARRAY))
ABASE)
(COND
([NOT (HARRAYP (COND
((LISTP APTR1)
(SETQ APTR1 (CAR APTR1)))
(T APTR1]
(LISPERROR "ARG NOT HARRAY" HARRAY)))
(SETQ ABASE (fetch (ARRAYP BASE) of APTR1))
(UNINTERRUPTABLY
[FRPTQ (fetch (ARRAYP LENGTH) of APTR1)
(\RPLPTR ABASE 0 NIL)
(\RPLPTR ABASE WORDSPERCELL NIL)
(SETQ ABASE (\ADDBASE ABASE (CONSTANT (ITIMES 2 WORDSPERCELL]
(\HASHVACANCIES APTR1))
(RETURN HARRAY])
(GETHASH
[LAMBDA (ITEM HARRAY) (* rmk: " 7-JUN-83 09:31")
(PROG [ABASE INDEX SKEY FIRSTINDEX REPROBE LIMIT (BITS (\HASHINGBITS ITEM))
(APTR1 (COND
((LISTP HARRAY)
(CAR HARRAY))
(HARRAY)
((LISTP SYSHASHARRAY)
(CAR SYSHASHARRAY))
(T SYSHASHARRAY]
(COND
((NOT (AND (ARRAYP APTR1)
(EQ (fetch (ARRAYP TYP) of APTR1)
\ST.HASH)))
(LISPERROR "ARG NOT HARRAY" HARRAY)))
(SETQ ABASE (fetch (ARRAYP BASE) of APTR1))
(SETQ INDEX (\FIRSTINDEX BITS APTR1)) (* Do first index outside of loop, so don't have to do
setup for fast case)
(COND
((EQ ITEM (SETQ SKEY (fetch (HASHINDEX KEY) of INDEX)))
(RETURN (fetch (HASHINDEX VALUE) of INDEX)))
((AND (NULL SKEY)
(NULL (fetch (HASHINDEX VALUE) of INDEX)))
(* Empty slot)
(RETURN NIL))) (* Perhaps we hit right on)
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS APTR1)) (* Compute reprobe interval)
(SETQ LIMIT (IDIFFERENCE (fetch (ARRAYP LENGTH) of APTR1)
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 Length is guaranteed to be a power of 2, we can speed this up a smidge by doing (LOGAND
(IPLUS INDEX REPROBE) (SUB1 Length)), instead of testing.)
(COND
((EQ INDEX FIRSTINDEX)
(RETURN NIL)))
(SETQ SKEY (fetch (HASHINDEX KEY) of INDEX))
(COND
((EQ SKEY ITEM)
(RETURN (fetch (HASHINDEX VALUE) of INDEX)))
((AND (NULL SKEY)
(NULL (fetch (HASHINDEX VALUE) of INDEX)))
(* Empty slot)
(RETURN)))
(GO LP])
(HARRAY
[LAMBDA (LEN) (* edited: "31-MAY-83 09:38")
(* Increments the length to be the next 2↑N-1, so that
hashkey can be computed with LOGAND instead of
IREMAINDER.)
(PROG [NCELLS (SIZE (find I (L ←(FIX LEN)) from 8 by I suchthat (IGREATERP I L]
(SETQ NCELLS (ADD1 (UNFOLD SIZE 2))) (* Add an extra pointer for vacancy count)
(COND
((OR (IGREATERP 0 SIZE)
(IGREATERP SIZE \MaxArrayLen)
(IGREATERP NCELLS \MaxArrayNCells))
(LISPERROR "ILLEGAL ARG" SIZE)))
(RETURN (\HASHVACANCIES (create ARRAYP
BASE ←(\ALLOCBLOCK NCELLS PTRBLOCK.GCT)
LENGTH ← SIZE
TYP ← \ST.HASH])
(HARRAYP
[LAMBDA (X) (* edited: "11-DEC-82 20:08")
(AND (ARRAYP X)
(EQ (fetch (ARRAYP TYP) of X)
\ST.HASH)
X])
(HARRAYSIZE
[LAMBDA (HARRAY) (* lmm "13-OCT-82 10:14")
(COND
((NULL HARRAY)
(SETQ HARRAY SYSHASHARRAY)))
[COND
((LISTP HARRAY)
(SETQ HARRAY (CAR HARRAY]
(COND
((HARRAYP HARRAY)
(* SUB1 cause vacancy slot is included in LENGTH, but should not be seen by user, else HARRAY on the value of
HARRAYSIZE would give a double-size array.)
(SUB1 (fetch (ARRAYP LENGTH) of HARRAY)))
(T (LISPERROR "ARG NOT HARRAY" HARRAY])
(MAPHASH
[LAMBDA (ARRAY MAPHFN) (* rmk: "17-NOV-82 08:59")
(DECLARE (LOCALVARS . T))
(PROG [SLOT POSTSLOT V (APTR1 (OR (HARRAYP (COND
((LISTP ARRAY)
(CAR ARRAY))
(ARRAY)
((LISTP SYSHASHARRAY)
(CAR SYSHASHARRAY))
(T SYSHASHARRAY)))
(LISPERROR "ARG NOT HARRAY" ARRAY]
(* This is the maphash expanded out)
(SETQ SLOT (fetch (ARRAYP BASE) of APTR1))
(SETQ POSTSLOT (\ADDBASE4 SLOT (fetch (ARRAYP LENGTH) of APTR1)))
LP [COND
((EQ SLOT POSTSLOT)
(RETURN ARRAY))
((SETQ V (fetch (HASHSLOT VALUE) of SLOT))
(APPLY* MAPHFN V (fetch (HASHSLOT KEY) of SLOT]
(SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
(GO LP])
(PUTHASH
[LAMBDA (ITEM VAL HARRAY) (* rmk: "26-MAR-83 09:04")
(PROG (ABASE DELINDEX INDEX SKEY FIRSTINDEX REPROBE LIMIT POSTSLOT APTR1 (BITS (\HASHINGBITS
ITEM)))
(* ABASE is used by HASHINDEX fields)
PHTOP (* Initialization of APTR1 done by SETQ so that it
happens again after the return from the possible rehash
error.)
(COND
((NOT (AND [ARRAYP (SETQ APTR1 (COND
((LISTP HARRAY)
(CAR HARRAY))
(HARRAY)
((LISTP SYSHASHARRAY)
(CAR SYSHASHARRAY))
(T SYSHASHARRAY]
(EQ (fetch (ARRAYP TYP) of APTR1)
\ST.HASH)))
(LISPERROR "ARG NOT HARRAY" HARRAY)))
(SETQ ABASE (fetch (ARRAYP BASE) of APTR1))
(SETQ INDEX (\FIRSTINDEX BITS APTR1))
(COND
((EQ ITEM (SETQ SKEY (fetch (HASHINDEX KEY) of INDEX)))
(GO FOUND))
((AND (NULL SKEY)
(NULL (fetch (HASHINDEX VALUE) of INDEX)))
(GO ITEMENTRY)))
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS APTR1))
(SETQ LIMIT (IDIFFERENCE (fetch (ARRAYP LENGTH) of APTR1)
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 INDEX (OR DELINDEX (RAID "No vacant slot in hasharray")))
(GO ITEMENTRY)))
(SETQ SKEY (fetch (HASHINDEX KEY) of INDEX))
(COND
((AND (NULL SKEY)
(NULL (fetch (HASHINDEX VALUE) of INDEX)))
(* NIL as a key and value means empty slot)
(SETQ INDEX (OR DELINDEX INDEX))
(GO ITEMENTRY))
((EQ SKEY ITEM) (* Found it)
(GO FOUND))
((AND (NULL DELINDEX)
(NULL (fetch (HASHINDEX VALUE) of INDEX)))
(* Key non-NIL but value NIL means deleted.)
(SETQ DELINDEX INDEX)))
(GO LP)
FOUND
(UNINTERRUPTABLY
(COND
((NULL VAL)
(replace (HASHINDEX KEY) of INDEX with "Deleted")
(* Unique string means we will never match a deleted
slot)
(add (fetch (POSTSLOT VACANCIES) of (\ADDBASE4 ABASE (fetch (ARRAYP LENGTH)
of APTR1)))
1)))
(replace (HASHINDEX VALUE) of INDEX with VAL))
(RETURN VAL)
ITEMENTRY (* Didn't find this item in table.
If VAL is NIL, nothing to do.)
(COND
((NULL VAL)
(RETURN)))
(SETQ POSTSLOT (\ADDBASE4 ABASE (fetch (ARRAYP LENGTH) of APTR1)))
(COND
((ZEROP (fetch (POSTSLOT VACANCIES) of POSTSLOT))
(SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY)))
(* 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 DELINDEX NIL)
(* DELINDEX may be a pointer into the old array, which we haven't used because hashvacancy counts only empty
slots, cause that's what terminates a reprobing chain)
(GO PHTOP)))
(UNINTERRUPTABLY
(add (fetch (POSTSLOT VACANCIES) of POSTSLOT)
-1) (* The KEY of POSTSLOT holds the vacancy count)
(replace (HASHINDEX KEY) of INDEX with ITEM)
(replace (HASHINDEX VALUE) of INDEX with VAL))
(RETURN VAL])
(REHASH
[LAMBDA (OLDAR NEWAR) (* rmk: "31-JAN-81 13:34")
(CLRHASH NEWAR)
(PROG [SLOT POSTSLOT V (APTR1 (COND
((LISTP OLDAR)
(CAR OLDAR))
(OLDAR)
((LISTP SYSHASHARRAY)
(CAR SYSHASHARRAY))
(T SYSHASHARRAY] (* This is the maphash expanded out)
(SETQ SLOT (fetch (ARRAYP BASE) of APTR1))
(SETQ POSTSLOT (\ADDBASE4 SLOT (fetch (ARRAYP LENGTH) of APTR1)))
LP (COND
((EQ SLOT POSTSLOT)
(RETURN NEWAR))
((SETQ V (fetch (HASHSLOT VALUE) of SLOT))
(PUTHASH (fetch (HASHSLOT KEY) of SLOT)
V NEWAR)))
(SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT))
(GO LP])
(\HASHVACANCIES
[LAMBDA (HA) (* lmm " 6-APR-81 11:21")
(PROG ((LEN (fetch (ARRAYP LENGTH) of HA)))
(replace (POSTSLOT VACANCIES) of (\ADDBASE4 (fetch (ARRAYP BASE) of HA)
LEN)
with (IPLUS (LRSH LEN 1)
(LRSH LEN 3))) (* This is 5/8)
(RETURN HA])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS HASHINDEX ((KEY (\GETBASEPTR (\ADDBASE4 ABASE DATUM)
0)
(\RPLPTR (\ADDBASE4 ABASE DATUM)
0 NEWVALUE))
(VALUE (\GETBASEPTR (\ADDBASE4 ABASE DATUM)
2)
(\RPLPTR (\ADDBASE4 ABASE DATUM)
2 NEWVALUE))
(NEXTINDEX (IPLUS DATUM WORDSPERQUAD))))
(BLOCKRECORD HASHSLOT ((KEY POINTER)
(VALUE POINTER))
[ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL 2])
(BLOCKRECORD POSTSLOT ((VACANCIES POINTER)))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \FIRSTINDEX MACRO [(BITS APTR1)
(LOGAND BITS (SUB1 (fetch (ARRAYP LENGTH) of APTR1])
(PUTPROPS \HASHINGBITS MACRO ((ITEM)
(LOGXOR (\LOLOC ITEM)
(\HILOC ITEM))))
(PUTPROPS \REPROBE MACRO ((BITS APTR)
1))
)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS SYSHASHARRAY)
)
(* END EXPORTED DEFINITIONS)
(* System entries for compiled code blocks)
(DEFINEQ
(\CODEARRAY
[LAMBDA (NBYTES ALIGNED) (* rmk: "30-DEC-82 12:15")
(PROG NIL (* NBYTES is the number of bytes required, ALIGNED is
the number of CELLS which must reside on same page)
(COND
((OR (IGREATERP 0 NBYTES)
(IGREATERP NBYTES 65535))
(LISPERROR "ILLEGAL ARG" NBYTES)))
(OR (ILESSP ALIGNED CELLSPERPAGE)
(ERROR "Code name table too big!"))
(RETURN (create ARRAYP
TYP ← \ST.CODE
BASE ←(\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL)
CODEBLOCK.GCT ALIGNED)
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])
)
(* Private entries)
(DEFINEQ
(\ARRAYTYPENAME
[LAMBDA (X) (* lmm "27-JUN-80 23:10")
(* 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))
(\ST.HASH (QUOTE HARRAYP))
(QUOTE ARRAYP])
(\ALLOCBLOCK
[LAMBDA (NCELLS GCTYPE ALIGN) (* rmk: "31-MAY-83 22:23")
(* NCELLS is number of cells wanted not counting overhead cell. For code arrays, ALIGN 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
((IGREATERP NCELLS 0)
(COND
((ILESSP NCELLS \ArrayBlockLinkingCells)
(SETQ NCELLS \ArrayBlockLinkingCells))
((IGREATERP NCELLS \MaxArrayNCells)
(ERROR "ARRAY STORAGE BLOCK TOO LARGE" NCELLS)))
(* NCELLS is number of data cells;
remember for allocation counter below)
(PROG (BLOCK (ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)))
(* ARLEN is number of cells to be allocated, including
overhead.)
RETRY
(UNINTERRUPTABLY
[SETQ BLOCK (COND
((\ALLOCOLDBLOCK ARLEN ALIGN))
((\ALLOCNEWBLOCK ARLEN ALIGN))
(T (RECLAIM) (* We're out of array space; our last chance is to
collect and hope something shows up on the free list.)
(OR (\ALLOCOLDBLOCK ARLEN ALIGN)
(GO FULL] (* BLOCK now points to the beginning of the actual block
of storage to be used)
(replace (ARRAYBLOCK INUSE) of BLOCK with T)
(replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with T)
(replace (ARRAYBLOCK GCTYPE) of BLOCK with (SELECTQ GCTYPE
(NIL UNBOXEDBLOCK.GCT)
(T
(* This branch can be removed when all callers are
upgraded to constants)
PTRBLOCK.GCT)
GCTYPE))
(.INCREMENT.ALLOCATION.COUNT. NCELLS) (* NCELLS because CREATEREF accounts for overhead cell)
(SETQ BLOCK (\ADDBASE BLOCK \ArrayBlockHeaderWords))
(\CREATEREF BLOCK)
(RETURN BLOCK))
FULL(LISPERROR "ARRAYS FULL" NIL T) (* User might release something, so retry.)
(GO RETRY])
(\ALLOCNEWBLOCK
[LAMBDA (ARLEN ALIGN) (* rmk: "18-NOV-82 10:04")
(DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage)) (* Returns pointer to first of an allocated block of
ARLEN cells, NIL if unsuccessful)
[COND
(ALIGN (* Enforce codeblock ALIGN by pre-allocating any
unacceptable storage, then getting a new block.)
(PROG (NLEFT (DATAWORD (\ADDBASE \ArrayFrLst \ArrayBlockHeaderWords)))
[COND
([NEQ CELLSPERQUAD (SETQ NLEFT (IDIFFERENCE CELLSPERQUAD
(IMOD (fetch CELLINPAGE
of DATAWORD)
CELLSPERQUAD]
(\PATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE \ArrayFrLst \ArrayBlockHeaderWords]
[COND
([IGREATERP ALIGN (SETQ NLEFT (IDIFFERENCE CELLSPERPAGE (fetch CELLINPAGE
of DATAWORD]
(* Check page first, cause if we did segment first and
succeeded but then failed on page, we would have to
check segment again.)
(\PATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE \ArrayFrLst \ArrayBlockHeaderWords]
[CHECK (EVENP (fetch CELLINPAGE of DATAWORD)
CELLSPERQUAD)
(ILEQ ALIGN (IDIFFERENCE CELLSPERPAGE (fetch CELLINPAGE of DATAWORD]
[COND
([IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
(SETQ NLEFT (IDIFFERENCE CELLSPERSEGMENT (fetch CELLINSEGMENT
of DATAWORD]
(* Code arrays cannot cross segment boundaries.
Note that ARLEN includes the overhead cells, hence the
extra subtraction.)
(\PATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE \ArrayFrLst \ArrayBlockHeaderWords]
(CHECK (ILEQ (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
(IDIFFERENCE CELLSPERSEGMENT (fetch CELLINSEGMENT of DATAWORD]
(PROG (FINALPAGE FINALWORD TRAILER (NEXTFREEBLOCK (\ADDBASE2 \ArrayFrLst ARLEN)))
(SETQ FINALWORD (\ADDBASE NEXTFREEBLOCK -1))
(* FINALWORD is pointer to the last word of the new block. The new \ArrayFrLst will be one past that.
The double \ADDBASE avoids large-int)
(COND
((IGREATERP (SETQ FINALPAGE (PAGELOC FINALWORD))
(IPLUS (LLSH \ARRAYspace 8)
\LastArrayPage))
(* Out of array space check. Make sure that there are enough pages before we make any global changes.
-
Probably, \LastArrayPage should be a page number, not an offset.)
(RETURN NIL)))
(SETQ TRAILER (\ADDBASE NEXTFREEBLOCK (IMINUS \ArrayBlockTrailerWords)))
LP [COND
((IGREATERP \NxtArrayPage FINALPAGE)
(* \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 \ArrayFrLst is the first word of a page)
(replace (ARRAYBLOCK ABFLAGS) of \ArrayFrLst with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ARLEN) of \ArrayFrLst with ARLEN)
(COND
((IGREATERP ARLEN \ArrayBlockHeaderCells) (* Header and Trailer coincide for tiny blocks that
\PATCHBLOCK might require.)
(replace (ARRAYBLOCK ABFLAGS) of TRAILER with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ARLEN) of TRAILER with ARLEN)))
(RETURN (PROG1 \ArrayFrLst (SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK]
(\NEWPAGE (create POINTER
PAGE# ← \NxtArrayPage))
(SETQ.NOREF \NxtArrayPage (ADD1 \NxtArrayPage))
(GO LP])
(\ALLOCOLDBLOCK
[LAMBDA (ARLEN ALIGN) (* rmk: "18-NOV-82 09:54")
(* Returns a block of the right size and alignment, or
NIL if one couldn't be found.)
(DECLARE (GLOBALVARS \FREEBLOCKLIST \ArrayFrLst))
(AND \FREEBLOCKLIST (PROG (FOUND DATAWORD LEN M (ROVER \FREEBLOCKLIST))
FREELP
(OR (IEQ \FreeArrayFlagWord (fetch (ARRAYBLOCK ABFLAGS) of ROVER))
(RAID "Array free list invalid"))
(COND
((ILEQ ARLEN (SETQ LEN (fetch (ARRAYBLOCK ARLEN) of ROVER)))
(* found a block which is big enough)
(SETQ M (IDIFFERENCE LEN ARLEN))
(* M is the number of cells left over)
(COND
((IGEQ M \MinArrayBlockSize)
(* leave the beginning of the block on the free list)
(SETQ FOUND (\ADDBASE2 ROVER M))
(SETQ DATAWORD (\ADDBASE FOUND \ArrayBlockHeaderWords))
(COND
([AND ALIGN (OR (ODDP (fetch CELLINPAGE of DATAWORD)
CELLSPERQUAD)
(IGREATERP ALIGN
(IDIFFERENCE CELLSPERPAGE
(fetch CELLINPAGE
of DATAWORD)))
(IGREATERP (IDIFFERENCE ARLEN
\ArrayBlockOverheadCells)
(IDIFFERENCE CELLSPERSEGMENT
(fetch CELLINSEGMENT
of DATAWORD]
(* Verify alignment before global changes)
(GO MISS)))
(replace (ARRAYBLOCK ARLEN) of FOUND with ARLEN)
(replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER)
of FOUND)
with ARLEN)
(replace (ARRAYBLOCK PASSWORD) of FOUND with
\ArrayBlockPassword)
(SETQ.NOREF \FREEBLOCKLIST ROVER)
(* Reset the freelist)
(replace (ARRAYBLOCK ARLEN) of ROVER with M)
(* Fix up header and trailer of ROVER to reflect new
length)
(replace (ARRAYBLOCK ABFLAGS) of (SETQ ROVER
(fetch (ARRAYBLOCK TRAILER)
of ROVER))
with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ARLEN) of ROVER with M))
(T (SETQ FOUND ROVER) (* Not enough cells left for a block, so remove the
whole thing from the freelist and return it)
(SETQ DATAWORD (\ADDBASE FOUND \ArrayBlockHeaderWords))
(COND
([AND ALIGN (OR (ODDP (fetch CELLINPAGE of DATAWORD)
CELLSPERQUAD)
(IGREATERP ALIGN
(IDIFFERENCE CELLSPERPAGE
(fetch CELLINPAGE
of DATAWORD)))
(IGREATERP (IDIFFERENCE ARLEN
\ArrayBlockOverheadCells)
(IDIFFERENCE CELLSPERSEGMENT
(fetch CELLINSEGMENT
of DATAWORD]
(GO MISS)))
(SETQ ARLEN LEN) (* Make ARLEN be the number of cells actually returned,
for appropriate zeroing.)
(\DELETEBLOCK FOUND)))
[\ZEROWORDS DATAWORD (\ADDBASE (\ADDBASE2 FOUND ARLEN)
(IMINUS (ADD1
\ArrayBlockTrailerWords]
(* clear out old garbage)
(RETURN FOUND)))
MISS(COND
((NEQ \FREEBLOCKLIST (SETQ ROVER (fetch FWD of ROVER)))
(* Not big enough, keep scanning)
(GO FREELP))
(T (RETURN NIL])
)
(* Functions for managing array garbage.)
(DEFINEQ
(\DELETEBLOCK
[LAMBDA (BASE) (* edited: "11-DEC-82 20:13")
(* PASSWORD has been checked by immediate caller, so
don't bother)
(PROG ((F (OR (fetch FWD of BASE)
(RAID "\FREEBLOCKLIST screwed up")))
(B (fetch BKWD of BASE)))
(COND
((EQ BASE F)
(SETQ.NOREF \FREEBLOCKLIST NIL)
(RETURN))
((EQ BASE \FREEBLOCKLIST)
(SETQ.NOREF \FREEBLOCKLIST F)))
(replace BKWD of F with B)
(replace FWD of B with F])
(\LINKBLOCK
[LAMBDA (BASE) (* rmk: "15-NOV-82 21:13")
(* Add BASE to the free list.
Assumes that BASE is a well-formed free block.)
(DECLARE (GLOBALVARS \FREEBLOCKLIST))
(COND
((IGEQ (fetch (ARRAYBLOCK ARLEN) of BASE)
\MinArrayBlockSize)
(COND
((NULL \FREEBLOCKLIST)
(replace FWD of BASE with BASE)
(replace BKWD of BASE with BASE))
(T (replace FWD of BASE with \FREEBLOCKLIST)
(replace BKWD of BASE with (fetch BKWD of \FREEBLOCKLIST))
(replace FWD of (fetch BKWD of \FREEBLOCKLIST) with BASE)
(replace BKWD of \FREEBLOCKLIST with BASE)))
(SETQ.NOREF \FREEBLOCKLIST BASE])
(\MERGEBACKWARD
[LAMBDA (BASE) (* rmk: "15-NOV-82 23:25")
(* Caller is uninterruptable and asserts that 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.)
(DECLARE (GLOBALVARS MERGEBACKFLAG))
(COND
([AND (NEQ BASE \ARRAYSPACE)
(NOT (fetch (ARRAYBLOCK INUSE) of (\ADDBASE BASE (IMINUS \ArrayBlockTrailerWords]
(PROG (PBASE PL (PTRAIL (\ADDBASE BASE (IMINUS \ArrayBlockTrailerWords)))
(L (fetch (ARRAYBLOCK ARLEN) of BASE)))
(OR (IEQ \ArrayBlockPassword (fetch PASSWORD of PTRAIL))
(RAID "Bad array block"))
(SETQ PL (fetch (ARRAYBLOCK ARLEN) of PTRAIL))
(COND
((IGREATERP PL (IDIFFERENCE \MaxArrayBlockSize L))
(* check if sum of PL+L is leq maximum.
Written this way to stay within small number range)
(\LINKBLOCK BASE)
(RETURN BASE)))
(SETQ PBASE (\ADDBASE2 BASE (IMINUS PL)))
(replace (ARRAYBLOCK ARLEN) of PBASE with (SETQ L (IPLUS L PL)))
(replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of PBASE) with L)
(* Assume password and inuse are still valid)
(COND
((OR (ILESSP PL \MinArrayBlockSize)
(NULL (fetch (ARRAYBLOCK FWD) of PBASE)))
(* PBASE was not on free list, need to do insertion.)
(\LINKBLOCK PBASE)))
(RETURN PBASE)))
(T (\LINKBLOCK BASE)
BASE])
(\MERGEFORWARD
[LAMBDA (BASE) (* rmk: "17-NOV-82 09:12")
(* 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.)
(DECLARE (GLOBALVARS \ArrayFrLst))
(PROG (NBASE NL (L (fetch (ARRAYBLOCK ARLEN) of BASE)))
(COND
((OR (EQ \ArrayFrLst (SETQ NBASE (\ADDBASE2 BASE L)))
(fetch (ARRAYBLOCK INUSE) of NBASE))
(RETURN NIL)))
(SETQ NL (fetch (ARRAYBLOCK ARLEN) of NBASE))
(OR (IEQ \ArrayBlockPassword (fetch PASSWORD of NBASE))
(RAID "Bad array block"))
(COND
((IGREATERP NL (IDIFFERENCE \MaxArrayBlockSize L))
(* check if sum of NL+L is leq maximum.
Written this way to stay within small number range)
(RETURN)))
(COND
((AND (IGEQ NL \MinArrayBlockSize)
(fetch FWD of NBASE)) (* Remove it only if it was linked in.
Check FWD cause code alignment in MAKEINIT leaves
unlinked blocks.)
(\DELETEBLOCK NBASE)))
(replace (ARRAYBLOCK ARLEN) of BASE with (SETQ NL (IPLUS L NL)))
(* Assume password is still valid)
(replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of BASE) with NL)
(COND
((ILESSP L \MinArrayBlockSize)
(* BASE was previously too small to be linked; maybe it's big enough now. Don't bother with NULL FWD test, cause
\MERGEBACKWARD would have linked in that case.)
(\LINKBLOCK BASE])
(\PATCHBLOCK
[LAMBDA (ARLEN) (* rmk: "15-NOV-82 23:20")
(* Throw away ARLEN cells starting with \ArrayFrLst.
Used to increment to the next page/segment boundary when
allocating code arrays)
(\MERGEBACKWARD (\ALLOCNEWBLOCK ARLEN])
(\RECLAIMARRAYBLOCK
[LAMBDA (P) (* edited: "31-MAY-83 18:47")
(* 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
((AND (IEQ \ArrayBlockPassword (fetch PASSWORD of B))
(fetch (ARRAYBLOCK INUSE) of B))
(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)))
NIL)
(replace (ARRAYBLOCK ABFLAGS) of B with \FreeArrayFlagWord)
(replace (ARRAYBLOCK ABFLAGS) of (fetch (ARRAYBLOCK TRAILER) of B) with
\FreeArrayFlagWord)
(\MERGEFORWARD (\MERGEBACKWARD B)))
(T (* RAID instead of \GCERROR because this error is
continuable with ↑N.)
(RAID "Bad array block reclaimed--continue with ↑N but save state ASAP"])
)
(DEFINEQ
(\BYTELT
[LAMBDA (A J) (* edited: "11-DEC-82 20:24")
(* 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 (ARRAYP A)
(ZEROP (fetch (ARRAYP ORIG) of A))
(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) (* edited: "11-DEC-82 20:23")
(* 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 (ARRAYP A)
(ZEROP (fetch (ARRAYP ORIG) of A))
(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) (* edited: "11-DEC-82 20:23")
(* 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 (ARRAYP A)
(ZEROP (fetch (ARRAYP ORIG) of A))
(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
(\GETBASESTRING
(LAMBDA (BASE BYTEOFFSET NCHARS) (* JonL "11-JUN-82 22:05")
((LAMBDA (NEW)
(\MOVEBYTES BASE BYTEOFFSET (fetch (STRINGP BASE) of NEW)
(fetch (STRINGP OFFST) of NEW)
NCHARS)
NEW)
(ALLOCSTRING NCHARS))))
(\PUTBASESTRING
(LAMBDA (BASE BYTEOFFSET SOURCE) (* JonL "11-JUN-82 21:59")
(* In addition to putting the bytes into memory, this guy returns the number of characters "written", since the
source may not be a STRINGP, bu will be coerced to one.)
(SELECTC (NTYPX SOURCE)
(\STRINGP (\MOVEBYTES (fetch (STRINGP BASE) of SOURCE)
(fetch (STRINGP OFFST) of SOURCE)
BASE BYTEOFFSET (SETQ SOURCE (fetch (STRINGP LENGTH) of SOURCE)))
SOURCE)
(\LITATOM (\MOVEBYTES (fetch (LITATOM PNAMEBASE) of SOURCE)
1 BASE BYTEOFFSET (SETQ SOURCE (fetch (LITATOM PNAMELENGTH)
of SOURCE)))
SOURCE)
(\PUTBASESTRING BASE BYTEOFFSET (MKSTRING SOURCE)))))
)
(* \ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \#BLOCKDATACELLS MACRO ((DATAWORD)
(IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of (\ADDBASE DATAWORD
(IMINUS
\ArrayBlockHeaderWords)))
\ArrayBlockOverheadCells)))
(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE (\ADDBASE BASE N)
N)))
(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N)
(\ADDBASE2 (\ADDBASE2 BASE N)
N)))
(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)
(ZEROP (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)
)
(* for MAKEINIT)
(DEFINEQ
(COPYSTRING
[LAMBDA (X) (* rrb "13-DEC-82 11:19")
(PROG ((N (LOCAL (NCHARS X)))
STR BASE OFFST)
(SETQ STR (ALLOCSTRING N))
(SETQ BASE (ffetch (STRINGP BASE) of STR))
(SETQ OFFST (ffetch (STRINGP OFFST) of STR))
[for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
(IPLUS (NTHCHARCODE X I]
(RETURN STR])
(PREINITARRAYS
[LAMBDA NIL (* lmm "11-MAR-81 10: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 \FREEBLOCKLIST \ArrayFrLst \NxtArrayPage))
(SETQ.NOREF \ArrayFrLst (VAG2 \ARRAYspace \ARRAYbase))
(SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst))
(SETQ.NOREF \FREEBLOCKLIST NIL])
(POSTINITARRAYS
[LAMBDA (AFTERCODEPTR CODESTARTPAGE) (* rmk: " 3-JUN-81 13:55")
(* 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.)
(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)
(\PATCHBLOCK EXTRACELLS)
(SETQ.NOREF \ArrayFrLst AFTERCODEPTR)
(SETQ.NOREF \NxtArrayPage (ADD1 (PAGELOC \ArrayFrLst])
(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 ALIGNED) (* rmk: "18-NOV-82 09:48")
(* 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 (NLEFT (DATAWORD (\ADDBASE (FILEARRAYBASE)
\ArrayBlockHeaderWords))
(ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)))
(* ARLEN is the number of cells in the array %.
ALIGNED is number of cells which must reside on same
page)
[COND
([NEQ CELLSPERQUAD (SETQ NLEFT (IDIFFERENCE CELLSPERQUAD (IMOD (fetch CELLINPAGE
of DATAWORD)
CELLSPERQUAD]
(FILEPATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE (FILEARRAYBASE)
\ArrayBlockHeaderWords]
[COND
([IGREATERP ALIGNED (SETQ NLEFT (IDIFFERENCE CELLSPERPAGE (fetch CELLINPAGE of DATAWORD]
(* Check page first, cause if we did segment first and
succeeded but then failed on page, we would have to
check segment again.)
(FILEPATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE (FILEARRAYBASE)
\ArrayBlockHeaderWords]
[COND
([IGREATERP NCELLS (SETQ NLEFT (IDIFFERENCE CELLSPERSEGMENT (fetch CELLINSEGMENT
of DATAWORD]
(FILEPATCHBLOCK NLEFT)
(SETQ DATAWORD (\ADDBASE (FILEARRAYBASE)
\ArrayBlockHeaderWords]
(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.HASH 3)
(\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.HASH 3)
(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.HASH 3)
(\ST.CODE 4)
(\ST.PTR 6)
(\ST.FLOAT 7)
(\ST.BIT 8)
(\ST.PTR2 11))
)
[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})
)
(DATATYPE STRINGP ((ORIG BITS 1) (* ORIG is always 1)
(NIL BITS 1)
(READONLY FLAG)
(NIL BITS 1)
(TYP BITS 4) (* TYP is always \ST.BYTE)
(BASE POINTER)
(LENGTH WORD)
(OFFST WORD))
TYP ← \ST.BYTE ORIG ← 1 (* while STRINGP is declared as a declaration, the
initialization really happens at MAKEINIT time under
INITDATATYPES using the DTDECLS list))
(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? (PROGN (DECLARE (GLOBALVARS \ArrayFrLst))
(AND (ILEQ \ARRAYspace (\HILOC DATUM))
(PTRGTP \ArrayFrLst DATUM])
]
(/DECLAREDATATYPE (QUOTE ARRAYP)
(QUOTE ((BITS 1)
(BITS 1)
FLAG
(BITS 1)
(BITS 4)
POINTER WORD WORD)))
(/DECLAREDATATYPE (QUOTE STRINGP)
(QUOTE ((BITS 1)
(BITS 1)
FLAG
(BITS 1)
(BITS 4)
POINTER WORD WORD)))
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \NxtArrayPage \FREEBLOCKLIST \ArrayFrLst)
)
(* for MAKEINIT)
(ADDTOVAR INITVALUES (\NxtArrayPage))
(ADDTOVAR INITPTRS (\FREEBLOCKLIST)
(\ArrayFrLst))
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING \ALLOCBLOCK \ALLOCNEWBLOCK \LINKBLOCK \MERGEBACKWARD \PATCHBLOCK)
(FNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK))
(ADDTOVAR MKI.SUBFNS (\ALLOCOLDBLOCK . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR))
(ADDTOVAR EXPANDMACROFNS \#BLOCKDATACELLS \ADDBASE2 \ADDBASE4)
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS LLARRAYELT COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2694 12260 (AIN 2704 . 4157) (AOUT 4159 . 5653) (ARRAY 5655 . 9219) (ARRAYSIZE 9221 .
9493) (ARRAYTYP 9495 . 10247) (ARRAYORIG 10249 . 10451) (COPYARRAY 10453 . 11146) (ALLOCSTRING 11148
. 12258)) (12261 18222 (ELT 12271 . 13671) (ELTD 13673 . 14323) (SETA 14325 . 16137) (SETD 16139 .
16885) (SUBARRAY 16887 . 18220)) (18247 28968 (CLRHASH 18257 . 18938) (GETHASH 18940 . 21139) (HARRAY
21141 . 21979) (HARRAYP 21981 . 22170) (HARRAYSIZE 22172 . 22716) (MAPHASH 22718 . 23624) (PUTHASH
23626 . 27771) (REHASH 27773 . 28565) (\HASHVACANCIES 28567 . 28966)) (30010 31456 (\CODEARRAY 30020
. 30701) (\FIXCODENUM 30703 . 31046) (\FIXCODEPTR 31048 . 31454)) (31485 42265 (\ARRAYTYPENAME 31495
. 31914) (\ALLOCBLOCK 31916 . 34589) (\ALLOCNEWBLOCK 34591 . 38405) (\ALLOCOLDBLOCK 38407 . 42263)) (
42316 49123 (\DELETEBLOCK 42326 . 42967) (\LINKBLOCK 42969 . 43830) (\MERGEBACKWARD 43832 . 45643) (
\MERGEFORWARD 45645 . 47462) (\PATCHBLOCK 47464 . 47851) (\RECLAIMARRAYBLOCK 47853 . 49121)) (49124
51458 (\BYTELT 49134 . 49872) (\BYTESETA 49874 . 50745) (\WORDELT 50747 . 51456)) (51459 52574 (
\GETBASESTRING 51469 . 51765) (\PUTBASESTRING 51767 . 52572)) (54020 60330 (COPYSTRING 54030 . 54509)
(PREINITARRAYS 54511 . 55053) (POSTINITARRAYS 55055 . 56996) (FILEARRAYBASE 56998 . 57289) (
FILEBLOCKTRAILER 57291 . 57642) (FILECODEBLOCK 57644 . 59435) (FILEPATCHBLOCK 59437 . 60328)))))
STOP