(FILECREATED " 3-Oct-84 14:59:49" {ERIS}<LISPNEW>SOURCES>LLARRAYELT.;1 75138
changes to: (FNS \CHECKARRAYBLOCK)
previous date: " 5-Sep-84 15:17:43" {ERIS}<LISP>HARMONY>SOURCES>LLARRAYELT.;1)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLARRAYELTCOMS)
(RPAQQ LLARRAYELTCOMS [(COMS (* code for arrays/strings)
(FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY ALLOCSTRING)
(DECLARE: DONTCOPY (MACROS ARRAYSIZE))
(FNS ELT ELTD SETA SETD SUBARRAY))
(COMS (* Hash arrays)
(FNS CLRHASH GETHASH HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE MAPHASH PUTHASH
REHASH \COPYHARRAYP)
(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 compiled code blocks)
(FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR))
[COMS (* Private entries)
(FNS \ARRAYTYPENAME)
(FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE)
(FNS \SHOW.ARRAY.FREELISTS \ARRAYFREELISTSIZES)
(DECLARE: DONTCOPY (MACROS EQPTR))
(FNS \ALLOCBLOCK \ALLOCNEWBLOCK \ALLOCOLDBLOCK \MAKEFREEARRAYBLOCK \CLEARCELLS
\ADDITIONALALIGNMENT \DELETEBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD
\MERGEFORWARD \PATCHBLOCK \RECLAIMARRAYBLOCK \#BLOCKDATACELLS)
(VARS \ARRAYMERGING)
(GLOBALVARS \ARRAYMERGING)
(FNS \BUCKETINDEX)
(CONSTANTS \MAXBUCKETINDEX)
(FNS \BYTELT \BYTESETA \WORDELT)
(P (MOVD? (QUOTE NILL)
(QUOTE \RECLAIMCODEBLOCK)))
(FNS \GETBASESTRING \PUTBASESTRING)
(* \ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing)
(DECLARE: DONTCOPY (EXPORT (MACROS \ADDBASE2 \ADDBASE4 \BYTELT \BYTESETA \WORDELT]
[COMS (* 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 \FREEBLOCKBUCKETS \ArrayFrLst \LASTARRAYPAGE)
(* for MAKEINIT)
(ADDVARS (INITVALUES (\NxtArrayPage)
(\LASTARRAYPAGE))
(INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst))
(INEWCOMS (FNS ALLOCSTRING \#BLOCKDATACELLS \ADDITIONALALIGNMENT
\ALLOCBLOCK \ALLOCNEWBLOCK \MAKEFREEARRAYBLOCK
\MERGEBACKWARD \PATCHBLOCK \LINKBLOCK)
(FNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE
FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK))
(MKI.SUBFNS (\ALLOCOLDBLOCK . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL))
(EXPANDMACROFNS \ADDBASE2 \ADDBASE4)
(RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE))
(RD.SUBFNS (EQPTR . EQUAL))
(RDPTRS (\FREEBLOCKBUCKETS))
(RDVALS (\ArrayFrLst)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS COPYSTRING PREINITARRAYS POSTINITARRAYS
FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK
FILEPATCHBLOCK]
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA HARRAYPROP])
(* code for arrays/strings)
(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) (* lmm "11-AUG-84 01:39")
(* 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)))
(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)
(* 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)
(PROG ((P BASE))
(FRPTQ NCELLS (\PUTBASEFLOATP P 0 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) (* 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) (* rmk: "22-Dec-83 00:04")
(COND
[(HARRAYP ARRAY)
(REHASH ARRAY (HARRAY (HARRAYSIZE ARRAY)
(HARRAYPROP ARRAY (QUOTE OVERFLOW]
(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])
)
(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) (* lmm " 7-Jun-84 17:54")
(\DTEST A (QUOTE ARRAYP))
(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)))
(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 (\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))])
)
(* Hash arrays)
(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) (* rmk: "28-Dec-83 16:43")
(PROG [ABASE INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT (BITS (\HASHINGBITS ITEM))
(APTR1 (\DTEST HARRAY (QUOTE HARRAYP]
(SETQ ABASE (fetch HARRAYPBASE of APTR1))
(SETQ INDEX (\FIRSTINDEX BITS APTR1)) (* Do first index outside of loop, so don't have to do
setup on fast case)
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
(COND
((EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
(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 APTR1)) (* Compute reprobe interval)
(SETQ LIMIT (IDIFFERENCE (ADD1 (fetch (HARRAYP LASTINDEX) 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 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
((EQ SKEY ITEM)
(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) (* rmk: "31-Dec-83 13:58")
(* 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))
(COND
((IGREATERP NCELLS \MaxArrayNCells)
(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])
(HARRAYP
[LAMBDA (X) (* rmk: "21-Dec-83 22:20")
(AND (type? HARRAYP X)
X])
(HARRAYPROP
[LAMBDA NARGS (* rmk: "31-Dec-83 13:45")
(* Nospread so we can tell whether a new value was
specified)
(PROG [HA (HARRAY (OR (AND (IGREATERP NARGS 0)
(ARG NARGS 1))
SYSHASHARRAY))
(PROP (AND (IGREATERP NARGS 1)
(ARG NARGS 2)))
(NEWVALUE (AND (IGREATERP NARGS 2)
(ARG NARGS 3]
(SETQ HA (\DTEST HARRAY (QUOTE HARRAYP))) (* Keep HARRAY explicitly so can tell LISTP case)
(RETURN (SELECTQ PROP
(SIZE (HARRAYSIZE HA))
[OVERFLOW (PROG1 (COND
[(LISTP HARRAY)
(PROG1 (CDR HARRAY)
(AND (IGREATERP NARGS 2)
(RPLACD HARRAY NEWVALUE]
(T (PROG1 (fetch OVERFLOWACTION of HA)
(AND (IGREATERP NARGS 2)
(replace OVERFLOWACTION of HA
with NEWVALUE]
(NUMKEYS (fetch NUMKEYS of HA))
(\ILLEGAL.ARG 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) (* bvm: "15-Aug-84 14:27")
(PROG (ABASE DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT (APTR1 (\DTEST HARRAY (QUOTE
HARRAYP)))
(BITS (\HASHINGBITS ITEM))) (* ABASE is used by HASHINDEX fields)
PHTOP
(SETQ ABASE (fetch HARRAYPBASE of APTR1))
(SETQ INDEX (\FIRSTINDEX BITS APTR1))
(SETQ SLOT (fetch (HASHINDEX HASHSLOT) of INDEX))
[COND
((EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)))
(GO FOUND))
((NULL (fetch (HASHSLOT VALUE) of SLOT))
(COND
((NULL SKEY) (* Null slot)
(GO ITEMENTRY))
(T (* Deleted slot: null value, non-nil key)
(SETQ DELSLOT SLOT]
(SETQ FIRSTINDEX INDEX)
(SETQ REPROBE (\REPROBE BITS APTR1))
(SETQ LIMIT (IDIFFERENCE (ADD1 (fetch (HARRAYP LASTINDEX) 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 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))
(COND
((AND (NULL SKEY)
(NULL (fetch (HASHSLOT VALUE) of SLOT))) (* NIL as a key and value means empty slot)
(AND DELSLOT (SETQ SLOT DELSLOT))
(GO ITEMENTRY))
((EQ SKEY ITEM) (* Found it)
(GO FOUND))
((AND (NULL DELSLOT)
(NULL (fetch (HASHSLOT VALUE) of SLOT))) (* Key non-NIL but value NIL means deleted.)
(SETQ DELSLOT SLOT)))
(GO LP)
FOUND
(UNINTERRUPTABLY
(COND
((NULL VAL)
(replace (HASHSLOT KEY) of SLOT with "Deleted")
(* Unique string means we will never match a deleted
slot)
(add (fetch NUMKEYS of APTR1)
-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
((ZEROP (fetch NULLSLOTS of APTR1))
(SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY)))
(SETQ APTR1 (\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 APTR1)
-1))
(add (fetch NUMKEYS of APTR1)
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])
)
(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)
)))
]
(/DECLAREDATATYPE (QUOTE HARRAYP)
(QUOTE (WORD WORD POINTER POINTER WORD WORD)))
(* 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)))
[ADDTOVAR SYSTEMRECLST
(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)
)))
]
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SYSHASHARRAY)
)
(* END EXPORTED DEFINITIONS)
(* System entries for compiled code blocks)
(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])
)
(* Private entries)
(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])
)
(DEFINEQ
(\CHECKARRAYBLOCK
[LAMBDA (BASE FREE ONFREELIST) (* lmm " 2-Oct-84 17:26")
(PROG (ERROR TRAILER)
(COND
((NOT (type? ARRAYBLOCK BASE))
(SETQ ERROR "not an arrayblock"))
((NEQ (fetch (ARRAYBLOCK PASSWORD) of BASE)
\ArrayBlockPassword)
(SETQ ERROR "ARRAY BLOCK PASSWORD WRONG"))
((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
(NOT FREE))
(SETQ ERROR "ARRAYBLOCK INUSE bit set wrong"))
((AND FREE (UNLESSRDSYS (NEQ (\REFCNT BASE)
1)
NIL))
(SETQ ERROR "FREE BLOCK, REFCOUNT NOT 1"))
([NEQ (fetch ARLEN of BASE)
(fetch ARLEN of (SETQ TRAILER (fetch (ARRAYBLOCK TRAILER) of BASE]
(SETQ ERROR "ARRAY BLOCK HEADER AND TRAILER LENGTH DON'T MATCH"))
((NEQ (fetch (ARRAYBLOCK PASSWORD) of TRAILER)
\ArrayBlockPassword)
(SETQ ERROR "trailer password wrong"))
((NEQ (fetch (ARRAYBLOCK INUSE) of BASE)
(NOT FREE))
(SETQ ERROR "ARRAYTRAILER INUSE bit set wrong"))
((OR (NOT ONFREELIST)
(ILESSP (fetch ARLEN of BASE)
\MinArrayBlockSize)) (* all of the checks for non-freelist)
(RETURN))
((OR (NOT (EQPTR (fetch FWD of (fetch BKWD of BASE))
BASE))
(NOT (EQPTR (fetch BKWD of (fetch FWD of BASE))
BASE)))
(SETQ ERROR "ARRAY BLOCK LINKS FOULED"))
[(AND NIL (bind [FBL ←(\ADDBASE2 \FREEBLOCKBUCKETS (\BUCKETINDEX (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 FWD of ROVER))
(\GETBASEPTR FBL 0]
(T (* Everything ok)
(RETURN)))
(COND
((UNLESSRDSYS \INTERRUPTABLE T)
(ERROR BASE ERROR))
(T (\MP.ERROR \MP.BADARRAYBLOCK ERROR BASE T)))
(RETURN ERROR])
(\PARSEARRAYSPACE
[LAMBDA (FN) (* lmm " 4-Sep-84 09:37")
(for (ROVER ← \ARRAYSPACE) repeatuntil [EQPTR \ArrayFrLst (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])
)
(DEFINEQ
(\SHOW.ARRAY.FREELISTS
[LAMBDA (SIZES) (* bvm: " 1-Aug-84 12:33")
(COND
((OR SIZES (SETQ SIZES STORAGE.ARRAYSIZES))
(printout NIL T " variable-datum free list: " T)
([LAMBDA (TOTAL)
(printout NIL T "Total cells free: " .I8 TOTAL " total pages: " .I4 (FOLDHI TOTAL
CELLSPERPAGE)
T T]
(for X in (\ARRAYFREELISTSIZES (for X in SIZES collect (LIST X 0 0)))
sum (PROGN (COND
((CAR X)
(printout NIL "le " (CAR X)))
(T (printout NIL "others ")))
(printout NIL 10 .I8 (CADR X)
" items; " .I8 (CADDR X)
" cells." T)
(CADDR X])
(\ARRAYFREELISTSIZES
[LAMBDA (SIZELST TEST) (* edited: "27-Aug-84 17:51")
(RESETFORM (RECLAIMMIN 65535)
(for BI from 0 to \MAXBUCKETINDEX
do (PROG (TRAILER (FBL (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BI)
0))
ROVER)
(OR FBL (RETURN))
(SETQ ROVER FBL)
FREELP
[COND
(TEST (SETQ TRAILER (fetch (ARRAYBLOCK TRAILER) of ROVER))
(OR (AND (IGEQ (fetch ARLEN of ROVER)
\MinArrayBlockSize)
(EQ \FreeArrayFlagWord (fetch (ARRAYBLOCK ABFLAGS)
of ROVER))
(EQ (fetch FWD of (fetch BKWD of ROVER))
ROVER)
(EQ (fetch BKWD of (fetch FWD of ROVER))
ROVER)
(EQ (\REFCNT (\ADDBASE ROVER \ArrayBlockHeaderWords))
1)
(IEQ \FreeArrayFlagWord (fetch (ARRAYBLOCK ABFLAGS)
of TRAILER))
(IEQ (fetch ARLEN of ROVER)
(fetch ARLEN of TRAILER)))
(printout T "bad array block found on free list " T]
(for X in SIZELST when (OR (NULL (CAR X))
(ILEQ (fetch ARLEN of ROVER)
(CAR X)))
do (add (CADR X)
1)
(add (CADDR X)
(fetch ARLEN of ROVER))
(RETURN))
(COND
((EQ (SETQ ROVER (fetch FWD of ROVER))
FBL)
(RETURN)))
(GO FREELP)))
SIZELST])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS EQPTR DMACRO (= . EQ))
)
)
(DEFINEQ
(\ALLOCBLOCK
[LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* lmm " 4-Sep-84 12:35")
(* 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
((IGREATERP NCELLS 0)
(COND
((ILESSP NCELLS \ArrayBlockLinkingCells)
(SETQ NCELLS \ArrayBlockLinkingCells))
((IGREATERP NCELLS \MaxArrayNCells)
(\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))
(* 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 INITONPAGE ALIGN))
((\ALLOCNEWBLOCK ARLEN INITONPAGE ALIGN))
(T (FRPTQ 10 (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 INITONPAGE 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))
(\CHECKARRAYBLOCK BLOCK NIL)
(.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 INITONPAGE ALIGN) (* lmm "27-AUG-84 03:24")
(DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage)) (* Returns pointer to first of an allocated block of
ARLEN cells, NIL if unsuccessful)
(PROG (FINALPAGE FINALWORD TRAILER NEXTFREEBLOCK NLEFT)
(COND
([AND (OR INITONPAGE ALIGN)
(NEQ 0 (SETQ NLEFT (\ADDITIONALALIGNMENT (fetch CELLINSEGMENT of \ArrayFrLst)
ARLEN INITONPAGE ALIGN]
(\PATCHBLOCK NLEFT)))
(SETQ 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))
(IDIFFERENCE \LASTARRAYPAGE \GUARDSTORAGEFULL))
(* Out of array space check. Make sure that there are
enough pages before we make any global changes.)
(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)
(RETURN (PROG1 (\MAKEFREEARRAYBLOCK \ArrayFrLst ARLEN)
(SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK]
(\MAKEMDSENTRY \NxtArrayPage 0)
(\NEW2PAGE (create POINTER
PAGE# ← \NxtArrayPage))
(SETQ.NOREF \NxtArrayPage (IPLUS \NxtArrayPage 2))
(GO LP])
(\ALLOCOLDBLOCK
[LAMBDA (ARLEN INITONPAGE ALIGN) (* lmm " 4-Sep-84 17:03")
(* Returns a block of the right size and alignment, or
NIL if one couldn't be found.)
(for BI from (\BUCKETINDEX ARLEN) to \MAXBUCKETINDEX bind ROVER FBL FREEBLOCK
when (AND (SETQ FREEBLOCK (\GETBASEPTR (SETQ FBL (\ADDBASE2 \FREEBLOCKBUCKETS BI))
0))
(for old (ROVER ← FREEBLOCK) eachtime (\CHECKARRAYBLOCK ROVER T T)
repeatuntil (EQ (SETQ ROVER (fetch (ARRAYBLOCK FWD) of ROVER))
FREEBLOCK)
bind LEN INITFREE when [IGEQ (SETQ LEN (fetch (ARRAYBLOCK ARLEN) of ROVER))
(IPLUS ARLEN (SETQ INITFREE
(\ADDITIONALALIGNMENT (fetch CELLINSEGMENT
of ROVER)
ARLEN INITONPAGE
ALIGN]
do (\DELETEBLOCK ROVER) (* take it off the free list)
(if (NEQ 0 INITFREE)
then (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK ROVER INITFREE))
(SETQ LEN (IDIFFERENCE LEN INITFREE))
(SETQ ROVER (\ADDBASE2 ROVER INITFREE)))
[if (NEQ LEN ARLEN)
then (\MERGEFORWARD (\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 ROVER
ARLEN)
(IDIFFERENCE LEN
ARLEN]
(if (OR (NEQ 0 INITFREE)
(NEQ LEN ARLEN))
then (\MAKEFREEARRAYBLOCK ROVER ARLEN))
(\CHECKARRAYBLOCK ROVER T)
(\CLEARCELLS (\ADDBASE2 ROVER \ArrayBlockHeaderCells)
(IDIFFERENCE ARLEN \ArrayBlockOverheadCells))
(* clear out old garbage)
(* signal that we found one)
(RETURN T)))
do (RETURN ROVER])
(\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])
(\CLEARCELLS
[LAMBDA (BASE NCELLS) (* lmm "25-Jul-84 21:10")
(\ZEROWORDS BASE (\ADDBASE (\ADDBASE BASE NCELLS)
(SUB1 NCELLS])
(\ADDITIONALALIGNMENT
[LAMBDA (CELLINSEGMENT ARLEN INITONPAGE ALIGN) (* lmm "14-Aug-84 09:57")
(* how many cells do we need to add to CELLINSEGMENT to
get an ARLEN long block which is aligned according to
INITONPAGE)
(PROG ((INITFREE 0)
NLEFT)
[COND
([AND ALIGN (NEQ ALIGN 1)
(NOT (ZEROP (IREMAINDER (IPLUS CELLINSEGMENT \ArrayBlockHeaderCells)
ALIGN]
(* this used to say ODDP, until I discovered that IMOD wasn't defined in the INIT.SYSOUT and ODDP uses IMOD.
It is a shame, I probably ought to just move ODDP (lmm))
(* not aligned)
(add INITFREE (IDIFFERENCE ALIGN (IREMAINDER (IPLUS CELLINSEGMENT
\ArrayBlockHeaderCells)
ALIGN]
[if (AND INITONPAGE (NEQ INITONPAGE 0))
then (COND
([IGREATERP INITONPAGE (SETQ NLEFT (IDIFFERENCE CELLSPERPAGE
(IMOD (IPLUS CELLINSEGMENT
(IPLUS INITFREE
\ArrayBlockHeaderCells))
CELLSPERPAGE]
(* not INITONPAGE cells on the page, go to next page
boundary)
(add INITFREE NLEFT)))
(COND
([IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)
(SETQ NLEFT (IDIFFERENCE CELLSPERSEGMENT
(IMOD (IPLUS CELLINSEGMENT INITFREE
\ArrayBlockHeaderCells)
CELLSPERSEGMENT]
(* Code arrays cannot cross segment boundaries.
Note that ARLEN includes the overhead cells, hence the
extra subtraction.)
(add INITFREE NLEFT]
(RETURN INITFREE])
(\DELETEBLOCK
[LAMBDA (BASE) (* lmm "27-Aug-84 16:46")
(* remove free block BASE from freeblocklist)
(\CHECKARRAYBLOCK BASE T T)
(PROG [(F (fetch FWD of BASE))
(B (fetch BKWD of BASE))
(FBL (\ADDBASE2 \FREEBLOCKBUCKETS (\BUCKETINDEX (fetch ARLEN of BASE]
(COND
((EQ BASE F)
(OR (EQ BASE (\GETBASEPTR FBL 0))
(\MP.ERROR \MP.BADDELETEBLOCK "deleting last block # FREEBLOCKLIST"))
(\PUTBASEPTR FBL 0 NIL)
(RETURN))
((EQ BASE (\GETBASEPTR FBL 0))
(\PUTBASEPTR FBL 0 F)))
(replace BKWD of F with B)
(replace FWD of B with F])
(\DELETEBLOCK?
[LAMBDA (BASE) (* lmm "27-AUG-84 02:36")
(if (AND (IGEQ (fetch ARLEN of BASE)
\MinArrayBlockSize)
(fetch FWD of BASE))
then (\DELETEBLOCK BASE])
(\LINKBLOCK
[LAMBDA (BASE) (* edited: " 4-Sep-84 18:09")
(* Add BASE to the free list.
Assumes that BASE is a well-formed free block.)
(AND \FREEBLOCKBUCKETS (PROG ([FBL (\ADDBASE2 \FREEBLOCKBUCKETS (\BUCKETINDEX (fetch ARLEN
of BASE]
FREEBLOCK)
(COND
((ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE)
\MinArrayBlockSize)
(\CHECKARRAYBLOCK BASE T)
(RETURN)))
(COND
((NULL (SETQ FREEBLOCK (\GETBASEPTR FBL 0)))
(replace (ARRAYBLOCK FWD) of BASE with BASE)
(replace (ARRAYBLOCK BKWD) of BASE with BASE))
(T (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) (* lmm " 4-Sep-84 08:56")
(* 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.)
(PROG (L PTRAIL PBASE PL)
[COND
([OR (NOT \ARRAYMERGING)
(EQ BASE \ARRAYSPACE)
(fetch (ARRAYBLOCK INUSE) of (SETQ PTRAIL (\ADDBASE BASE (IMINUS
\ArrayBlockTrailerWords]
(RETURN (\LINKBLOCK BASE]
[COND
([IGREATERP (SETQ PL (fetch (ARRAYBLOCK ARLEN) of PTRAIL))
(IDIFFERENCE \MaxArrayBlockSize (SETQ L (fetch (ARRAYBLOCK ARLEN)
of BASE]
(* check if sum of PL+L is leq maximum.
Written this way to stay within small number range)
(RETURN (\LINKBLOCK BASE]
(SETQ PBASE (\ADDBASE2 BASE (IMINUS PL)))
(\CHECKARRAYBLOCK PBASE T)
(\DELETEBLOCK? PBASE)
(RETURN (\LINKBLOCK (\MAKEFREEARRAYBLOCK PBASE (IPLUS L PL])
(\MERGEFORWARD
[LAMBDA (BASE) (* lmm " 4-Sep-84 12:39")
(* 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.)
(\CHECKARRAYBLOCK BASE T T)
(PROG (NBASE NL (L (fetch (ARRAYBLOCK ARLEN) of BASE)))
(COND
((OR (NOT \ARRAYMERGING)
(EQ \ArrayFrLst (SETQ NBASE (\ADDBASE2 BASE L)))
(fetch (ARRAYBLOCK INUSE) of NBASE))
(RETURN NIL)))
(\CHECKARRAYBLOCK NBASE T)
(SETQ NL (fetch (ARRAYBLOCK ARLEN) of NBASE))
(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)))
(\DELETEBLOCK? NBASE)
(\DELETEBLOCK? BASE)
(\LINKBLOCK (\MAKEFREEARRAYBLOCK BASE (IPLUS L NL])
(\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) (* 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])
(\#BLOCKDATACELLS
[LAMBDA (DATAWORD) (* rmk: "15-Aug-84 13:39")
(* Returns the number of cells in this physical arrayblock. Compiled closed so that we can change internal
representations without clients needing to be recompiled.)
(IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of (\ADDBASE DATAWORD (IMINUS \ArrayBlockHeaderWords)))
\ArrayBlockOverheadCells])
)
(RPAQQ \ARRAYMERGING T)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ARRAYMERGING)
)
(DEFINEQ
(\BUCKETINDEX
[LAMBDA (N) (* lmm "27-AUG-84 02:52")
(* should be smarter table index)
(IMIN (INTEGERLENGTH N)
\MAXBUCKETINDEX])
)
(DECLARE: EVAL@COMPILE
(RPAQQ \MAXBUCKETINDEX 30)
(CONSTANTS \MAXBUCKETINDEX)
)
(DEFINEQ
(\BYTELT
[LAMBDA (A J) (* rmk: "30-Dec-83 13:15")
(* 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!)
(\DTEST A (QUOTE ARRAYP))
(OR [AND (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) (* rmk: "30-Dec-83 13:16")
(* 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!)
(\DTEST A (QUOTE ARRAYP))
(OR [AND (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) (* rmk: "30-Dec-83 13:16")
(* A special function for system accesses to 0-origin
word arrays, This compiles open into a GETBASE, with no
checking for argument validity!)
(\DTEST A (QUOTE ARRAYP))
(OR (AND (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])
)
(MOVD? (QUOTE NILL)
(QUOTE \RECLAIMCODEBLOCK))
(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 \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 (* edited: "27-Aug-84 17:52")
(* 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 \NxtArrayPage))
(SETQ.NOREF \ArrayFrLst (\VAG2 \ARRAYspace \ARRAYbase))
(SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst))
(SETQ.NOREF \LASTARRAYPAGE \ENDARRAYPAGE])
(POSTINITARRAYS
[LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (* edited: "27-Aug-84 17:49")
(* 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)
(\PATCHBLOCK EXTRACELLS)
(SETQ.NOREF \ArrayFrLst AFTERCODEPTR) (* \NxtArrayPage is the next page that needs to be
NEWPAGEd)
(SETQ.NOREF \NxtArrayPage CODENEXTPAGE])
(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.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
(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
(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \ArrayFrLst \LASTARRAYPAGE)
)
(ADDTOVAR INITVALUES (\NxtArrayPage)
(\LASTARRAYPAGE))
(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS)
(\ArrayFrLst))
(ADDTOVAR INEWCOMS (FNS ALLOCSTRING \#BLOCKDATACELLS \ADDITIONALALIGNMENT \ALLOCBLOCK \ALLOCNEWBLOCK
\MAKEFREEARRAYBLOCK \MERGEBACKWARD \PATCHBLOCK \LINKBLOCK)
(FNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK))
(ADDTOVAR MKI.SUBFNS (\ALLOCOLDBLOCK . NILL)
(\MERGEFORWARD . NILL)
(\FIXCODENUM . I.FIXUPNUM)
(\FIXCODEPTR . I.FIXUPPTR)
(\CHECKARRAYBLOCK . NILL))
(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4)
(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE))
(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL))
(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS))
(ADDTOVAR RDVALS (\ArrayFrLst))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS COPYSTRING PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER
FILECODEBLOCK FILEPATCHBLOCK)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA HARRAYPROP)
)
(PUTPROPS LLARRAYELT COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3588 13020 (AIN 3598 . 5241) (AOUT 5243 . 6824) (ARRAY 6826 . 10144) (ARRAYSIZE 10146
. 10288) (ARRAYTYP 10290 . 10984) (ARRAYORIG 10986 . 11162) (COPYARRAY 11164 . 11906) (ALLOCSTRING
11908 . 13018)) (13182 18483 (ELT 13192 . 14254) (ELTD 14256 . 14916) (SETA 14918 . 16481) (SETD 16483
. 17239) (SUBARRAY 17241 . 18481)) (18508 29645 (CLRHASH 18518 . 19142) (GETHASH 19144 . 21090) (
HARRAY 21092 . 21384) (HASHARRAY 21386 . 22440) (HARRAYP 22442 . 22583) (HARRAYPROP 22585 . 23634) (
HARRAYSIZE 23636 . 23810) (MAPHASH 23812 . 24558) (PUTHASH 24560 . 28104) (REHASH 28106 . 28847) (
\COPYHARRAYP 28849 . 29643)) (32742 34214 (\CODEARRAY 32752 . 33432) (\FIXCODENUM 33434 . 33778) (
\FIXCODEPTR 33780 . 34212)) (34243 34645 (\ARRAYTYPENAME 34253 . 34643)) (34646 37682 (
\CHECKARRAYBLOCK 34656 . 37024) (\PARSEARRAYSPACE 37026 . 37680)) (37683 39955 (\SHOW.ARRAY.FREELISTS
37693 . 38393) (\ARRAYFREELISTSIZES 38395 . 39953)) (40042 55789 (\ALLOCBLOCK 40052 . 42804) (
\ALLOCNEWBLOCK 42806 . 44640) (\ALLOCOLDBLOCK 44642 . 46583) (\MAKEFREEARRAYBLOCK 46585 . 47084) (
\CLEARCELLS 47086 . 47272) (\ADDITIONALALIGNMENT 47274 . 49151) (\DELETEBLOCK 49153 . 49936) (
\DELETEBLOCK? 49938 . 50195) (\LINKBLOCK 50197 . 51491) (\MERGEBACKWARD 51493 . 52731) (\MERGEFORWARD
52733 . 53796) (\PATCHBLOCK 53798 . 54189) (\RECLAIMARRAYBLOCK 54191 . 55344) (\#BLOCKDATACELLS 55346
. 55787)) (55883 56151 (\BUCKETINDEX 55893 . 56149)) (56239 58609 (\BYTELT 56249 . 56998) (\BYTESETA
57000 . 57882) (\WORDELT 57884 . 58607)) (58664 59774 (\GETBASESTRING 58674 . 58968) (\PUTBASESTRING
58970 . 59772)) (60996 67483 (COPYSTRING 61006 . 61485) (PREINITARRAYS 61487 . 62030) (POSTINITARRAYS
62032 . 64130) (FILEARRAYBASE 64132 . 64424) (FILEBLOCKTRAILER 64426 . 64780) (FILECODEBLOCK 64782 .
66579) (FILEPATCHBLOCK 66581 . 67481)))))
STOP