(FILECREATED "14-Mar-85 12:23:25" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;33 50963
changes to: (FNS \ASSIGNDATATYPE1)
previous date: "14-Mar-85 11:16:21" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;32)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLDATATYPECOMS)
(RPAQQ LLDATATYPECOMS ((COMS (* Storage management)
(FNS NTYPX \ALLOCMDSPAGE \ALLOCPAGEBLOCK \MAPMDS \CHECKFORSTORAGEFULL
\DOSTORAGEFULLINTERRUPT \SET.STORAGE.STATE \ADVANCE.STORAGE.STATE
\NEW2PAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE \ASSIGNDATATYPE1
\ASSIGN.DATATYPE \TYPENUMBERFROMNAME CREATECELL \CREATECELL)
(INITVARS (CROSSCOMPILING)
(ASSIGNDATATYPE.ASKUSERWAIT 300)
(\STORAGEFULLSTATE)
(\STORAGEFULL))
(GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL
\SYSTEMCACHEVARS \NxtArrayPage)
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT))
[COMS (* fetch and replace)
(FNS FETCHFIELD REPLACEFIELD BOXCOUNT CONSCOUNT \DTEST \DTESTFAIL GETDESCRIPTORS
GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL PUTBASEPTRX /REPLACEFIELD TYPENAME
\TYPENAMEFROMNUMBER \BLOCKDATAP USERDATATYPES DATATYPEP DATATYPES)
(P (MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD))
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD))
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL]
[COMS (* STORAGE)
(FNS STORAGE STORAGE.LEFT \STORAGE.TYPE \STLINP \STMDSTYPE \STORAGE.HUNKTYPE)
(DECLARE: DONTCOPY (RECORDS HUNKSTAT))
(INITVARS (STORAGE.ARRAYSIZES (QUOTE (4 16 64 256 1024 4096 16384 NIL]
(DECLARE: (EXPORT (MACROS PUTBASEPTRX))
(EXPORT (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP
\VMEMPAGEP \STREAM))
DONTCOPY
(EXPORT (RECORDS DTD)
(MACROS \GETDTD)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
(GLOBALVARS \NxtMDSPage \LeastMDSPage \MDSFREELISTPAGE \MaxSysTypeNum
\MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE \PENDINGINTERRUPT))
(CONSTANTS * STORAGEFULLSTATES)
(VARS DTDECLS))
[COMS (* for MAKEINIT)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(DECLARE: DONTCOPY
(ADDVARS (INITVALUES (\NxtMDSPage \FirstMDSPage)
(\LeastMDSPage \FirstMDSPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE
\INITMDSPAGE \ASSIGNDATATYPE1 \TYPENUMBERFROMNAME
\CREATECELL \NEW2PAGE)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS DTDECLS))
(RDCOMS (FNS NTYPX TYPENAME))
(RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X)
(QUOTE ARRAYP)))
(EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS
\PUTBITS \TESTBITS GETBASEBITS PUTBASEBITS
FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL
REPLACEFIELDVAL NCREATE)
(MKI.SUBFNS (\GCDISABLED . NILL)
(CREATECELL . I.\CREATECELL)
(\CHECKFORSTORAGEFULL . NILL)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES]
(LOCALVARS . T)
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
DTDECLARE))))
(* Storage management)
(DEFINEQ
(NTYPX
(LAMBDA (X) (* JonL "10-Nov-84 21:51")
(* usually done in microcode -
this def used by MAKEINIT too)
(LOGAND (\GETBASE \MDSTypeTable (FOLDLO (fetch (POINTER PAGE#) of X)
(CONSTANT (IQUOTIENT \MDSIncrement WORDSPERPAGE))))
\TT.TYPEMASK)))
(\ALLOCMDSPAGE
[LAMBDA (TYP) (* bvm: " 9-Jan-85 15:44")
(PROG (VP VPTR)
BEG [COND
[(SETQ VP \MDSFREELISTPAGE)
(SETQ VPTR (create POINTER
PAGE# ← VP))
(PROG ((NXT (\GETBASEPTR VPTR 0)))
(COND
((AND NXT (NOT (SMALLP NXT)))
(\MP.ERROR \MP.BADMDSFREELIST "MDS Free Page link bad. ↑N to continue"
(PROG1 \MDSFREELISTPAGE (SETQ \MDSFREELISTPAGE)))
(GO BEG))
(T (SETQ \MDSFREELISTPAGE NXT]
(T (\CHECKFORSTORAGEFULL)
(SETQ VP \NxtMDSPage)
(SETQ \NxtMDSPage (IDIFFERENCE VP (FOLDLO \MDSIncrement PAGESPERSEGMENT)))
(* Allocates 2 MDS pages)
(SETQ VPTR (create POINTER
PAGE# ← VP))
(\NEWPAGE (\ADDBASE (\NEWPAGE VPTR)
WORDSPERPAGE]
(\MAKEMDSENTRY VP (COND
((\GCDISABLED)
(LOGOR TYP \TT.NOREF))
((EQ TYP \VMEMPAGEP)
(LOGOR \VMEMPAGEP \TT.LISPREF))
(T TYP))) (* Fill in type table about whether the pointer we pass
to \NEWPAGE is refcounted or not)
(RETURN VPTR])
(\ALLOCPAGEBLOCK
[LAMBDA (NPAGES) (* bvm: "11-Mar-85 18:05")
(UNINTERRUPTABLY
(* * Allocates a continguous chunk of NPAGES pages. Currently there is no provision for giving them back.)
(PROG (NEWMDSPAGE RESULT)
[COND
([GREATERP (PLUS \NxtArrayPage \GUARDSTORAGEFULL)
(SETQ NEWMDSPAGE (IDIFFERENCE \NxtMDSPage (SETQ NPAGES
(CEIL NPAGES (FOLDLO \MDSIncrement
WORDSPERPAGE]
(COND
((AND (EQ (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
\SFS.SWITCHABLE)
(LESSP \NxtArrayPage NEWMDSPAGE))
(* Go ahead anyway)
)
(T (* Might want to fix this up so we can take a bite out
of the upper 32mb before the lower stuff is used)
(RETURN NIL]
(to NPAGES as [BASE ←(SETQ RESULT (create POINTER
PAGE# ←(IPLUS NEWMDSPAGE (FOLDLO
\MDSIncrement
WORDSPERPAGE]
by (\ADDBASE BASE WORDSPERPAGE)
do (* Allocate the new pages. Leave them having the
default type, namely type 0, don't refcnt)
(\NEWPAGE BASE))
(SETQ \NxtMDSPage NEWMDSPAGE)
(RETURN RESULT)))])
(\MAPMDS
[LAMBDA (TYPE FN) (* bvm: " 9-Jan-85 15:56")
(* * Applies FN to each virtual page number that is of type TYPE, or to all MDS pages if TYPE is NIL)
(OR (NULL TYPE)
(FIXP TYPE)
(SETQ TYPE (\TYPENUMBERFROMNAME TYPE)))
(CHECK (EQ (FOLDLO \MDSIncrement PAGESPERSEGMENT)
2)) (* I'd put this FOLDLO as the increment in the FOR
below, but the translation is atrocious)
(for I from 0 to (COND
((EQ \STORAGEFULLSTATE \SFS.FULLYSWITCHED)
1)
(T 0))
bind TYP
do
(* This is pretty grody because of the two different regions MDS can live in. Could just do everything from
(IMIN \NxtMDSPage \LeastMDSPage) to \MaxMDSPage but waste time on the stuff in between)
(for VP from (COND
((EQ I 0)
(IMIN \NxtMDSPage \LeastMDSPage))
(T \NxtMDSPage))
by 2 to (COND
((EQ I 0)
\SecondArrayPage)
(T \MaxMDSPage))
do
(* * We could just access \MDSTypeTable directly here, but since NTYPX should be ucoded, we benefit by
"modularizing" this access.)
(COND
((OR (EQ (SETQ TYP (NTYPX (create POINTER
PAGE# ← VP)))
TYPE)
(AND (NULL TYPE)
(NEQ TYP 0)
(NEQ TYP \SMALLP)))
(SPREADAPPLY* FN VP])
(\CHECKFORSTORAGEFULL
[LAMBDA (NPAGES) (* bvm: "19-Jan-85 18:55")
(DECLARE (GLOBALVARS \INTERRUPTSTATE \PENDINGINTERRUPT))
(* * Take appropriate action if storage is getting full. NPAGES is size of attempted allocation or NIL for MDS
requests. Complications here because array space and MDS grow toward each other in two separate areas: the first 8MB
of vmem and the remaining 24MB. Some machines cannot use the latter, so have to signal storage full when the first
fills up. Other machines have to know when to switch over. Array space usually gets switched to the high segment
before MDS, since MDS can eat the lo space in small increments all the way to the end -
Returns T if storage is ok, 0 if storage is ok but \NxtArrayPage changed, and NIL if storage is nearly full)
(UNINTERRUPTABLY
[PROG (PAGESLEFT)
(RETURN (COND
((OR (ILESSP (SETQ PAGESLEFT (IPLUS (IDIFFERENCE \NxtMDSPage \NxtArrayPage)
(FOLDLO \MDSIncrement WORDSPERPAGE)))
\GUARDSTORAGEFULL)
NPAGES)
(SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
((LIST \SFS.NOTSWITCHABLE \SFS.FULLYSWITCHED)
(COND
((ILESSP PAGESLEFT 0)
(while T do (\MP.ERROR \MP.MDSFULL "Storage completely full")
))
((AND (ILEQ PAGESLEFT \GUARD1STORAGEFULL)
(NEQ \STORAGEFULL 0))
(SETQ \STORAGEFULL 0)
(\MP.ERROR \MP.MDSFULLWARNING
"Space getting VERY full. Please save and reload a.s.a.p. Type control-N to continue now."))
((NOT \STORAGEFULL)
(SETQ \STORAGEFULL T)
(* Note this is uninterruptable)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T)))
(\DORECLAIM)
NIL)
(\SFS.SWITCHABLE (* We have verified that we can use the full 32MB, but
haven't switched there yet)
(OR [COND
[(NULL NPAGES)
(* Want MDS)
(COND
((ILEQ PAGESLEFT 0)
(SETQ \LeastMDSPage \NxtArrayPage)
(SETQ \NxtMDSPage \SecondMDSPage)
(\ADVANCE.STORAGE.STATE
\SFS.FULLYSWITCHED)
(\ADVANCE.ARRAY.SEGMENTS
\SecondArrayPage]
(T
(* Want array space)
(COND
((IGREATERP NPAGES PAGESLEFT)
(* Have to switch array space over, but leave MDS to
fill the rest of the low pages)
(SETQ \LeastMDSPage \NxtArrayPage)
(\ADVANCE.STORAGE.STATE
\SFS.ARRAYSWITCHED)
(\ADVANCE.ARRAY.SEGMENTS
\SecondArrayPage]
T))
(\SFS.ARRAYSWITCHED (COND
((ILESSP \NxtMDSPage \LeastMDSPage)
(* Finally used up lo MDS, so switch over to hi)
(SETQ \NxtMDSPage \SecondMDSPage)
(\ADVANCE.STORAGE.STATE \SFS.FULLYSWITCHED)
T)
((AND NPAGES (IGEQ (IPLUS NPAGES
\GUARDSTORAGEFULL)
(IDIFFERENCE
\SecondMDSPage
\NxtArrayPage)))
(* MDS still in lo area, arrays in hi area, and we're asking for too big an array! Unlikely, but handle it as a
storage full case)
NIL)
(T T)))
(SHOULDNT])])
(\DOSTORAGEFULLINTERRUPT
[LAMBDA NIL (* bvm: "13-Feb-85 16:28")
(replace STORAGEFULL of \INTERRUPTSTATE with NIL)
(PROG ((HELPFLAG (QUOTE BREAK!)))
(LISPERROR "STORAGE FULL" (QUOTE "save your work & reload a.s.a.p.")
T])
(\SET.STORAGE.STATE
[LAMBDA NIL (* bvm: "15-Jan-85 14:29")
(PROG1 (SETQ \STORAGEFULLSTATE (COND
((SELECTC \MACHINETYPE
(\DORADO T)
(\DANDELION (NEQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage)))
NIL) (* we can use high addresses)
\SFS.SWITCHABLE)
(T \SFS.NOTSWITCHABLE)))
(push \SYSTEMCACHEVARS (QUOTE \STORAGEFULLSTATE))
(* Want to recompute this if we come back from logout)
])
(\ADVANCE.STORAGE.STATE
[LAMBDA (FLG) (* bvm: " 9-Jan-85 15:30")
(* Bump the flag that tells what state storage allocation is in with respect to the 8MB -- 32MB distinction.
Also remove flag from \SYSTEMCACHEVARS since it can no longer get recomputed)
(SETQ \STORAGEFULLSTATE FLG)
(replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535)
(SETQ \SYSTEMCACHEVARS (DREMOVE (QUOTE \STORAGEFULLSTATE)
\SYSTEMCACHEVARS])
(\NEW2PAGE
[LAMBDA (BASE) (* edited: " 6-SEP-83 16:05")
(\NEWPAGE (\ADDBASE (\NEWPAGE BASE)
WORDSPERPAGE])
(\MAKEMDSENTRY
[LAMBDA (VP V) (* lmm "30-DEC-81 17:39")
(\PUTBASE \MDSTypeTable (LRSH VP 1)
V])
(\GCTYPE
(LAMBDA (TYPENUM DTD) (* JonL " 9-Dec-84 23:20")
(if (OR (EQ CDRCODING 0)
(NEQ TYPENUM \LISTP))
then
(* Note: it is possible, albeit unlikely, that \ALLOCMDSPAGE will eventually cause a CREATECELL to occur.
Hence, DTD:DTDFREE might possibly be non-NIL by the time we get back here, which is why it is included below)
(replace DTDFREE of DTD with (\INITMDSPAGE (\ALLOCMDSPAGE TYPENUM)
(fetch DTDSIZE of DTD)
(fetch DTDFREE of DTD)
TYPENUM)))))
(\INITMDSPAGE
[LAMBDA (BASE SIZE PREV) (* bvm: " 6-Jan-85 22:24")
(* * chain free list thru page at BASE of items SIZE long -
return last element)
(PROG ((SLOP (IREMAINDER WORDSPERPAGE SIZE))
NPAGES LIMIT)
(* * Refinement, mostly for benefit of hunking: try to keep objects from straddling page boundaries.
SLOP is how much is left over on a page after you have filled it with objects. If this SLOP is less than half the
size of an object, then you can start your next allocation at the beginning of the next page without any loss.
Thus, the algorithm here either allocates several pages individually, or treats the entire expanse as one big block
to slice up. Computation here assumes \MDSIncrement is 2 pages. Might want to have the AND test actually be a flag
in the DTD once and for all)
(COND
((AND (NEQ SLOP 0)
(ILESSP SLOP (LRSH SIZE 1))
(ILESSP SIZE WORDSPERPAGE)) (* Make everyone start at page boundaries.
Third condition needed for datatypes bigger than a
page)
(SETQ NPAGES (IQUOTIENT \MDSIncrement WORDSPERPAGE))
(SETQ LIMIT WORDSPERPAGE))
(T (SETQ NPAGES 1)
(SETQ LIMIT \MDSIncrement)))
(to NPAGES
do (for (DISP ← 0) while (ILEQ (add DISP SIZE)
LIMIT)
do (\PUTBASEPTR BASE 0 PREV)
(SETQ PREV BASE)
(SETQ BASE (\ADDBASE BASE SIZE)))
(SETQ BASE (\ADDBASE BASE SLOP)))
(RETURN PREV])
(\ASSIGNDATATYPE1
[LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS) (* lmm "14-Mar-85 12:20")
(PROG ((NTYPX (\TYPENUMBERFROMNAME NAME))
DTD)
[COND
(NTYPX (* a datatype of this name already allocated)
(SETQ DTD (\GETDTD NTYPX))
(COND
((AND (EQUAL PTRFIELDS (fetch DTDPTRS of DTD))
(EQUAL SIZE (fetch DTDSIZE of DTD)))
(* has same shape, can reuse DTD)
(replace DTDDESCRS of DTD with DESCRIPTORS)
(replace DTDTYPESPECS of DTD with SPECS)
(RETURN NTYPX))
([OR (EQ CROSSCOMPILING T)
(AND CROSSCOMPILING (NEQ (QUOTE Y)
(ASKUSER 30 (SELECTQ CROSSCOMPILING
(Y (QUOTE Y))
(QUOTE N))
(LIST (if SIZE
then
"OK TO REDECLARE DATATYPE "
else "OK to deallocate DATATYPE ")
NAME]
(* don't do it if cross compiling)
(RETURN))
((IGREATERP NTYPX \MaxSysTypeNum)
(UNINTERRUPTABLY
(replace DTDNAME of DTD with (\ATOMPNAMEINDEX (QUOTE **DEALLOC**)))
(replace DTDDESCRS of DTD with NIL)
(replace DTDTYPESPECS of DTD with NIL)))
(T (* can't mess with sys types)
(ERROR "ILLEGAL DATA TYPE" NAME]
(if (NOT SIZE)
then (* only called to deallocate old datatype)
else (COND
((EQ \MaxTypeNumber \EndTypeNumber)
(LISPERROR "DATA TYPES FULL" NAME)))
(UNINTERRUPTABLY
(SETQ NTYPX (add \MaxTypeNumber 1))
(SETQ DTD (\GETDTD NTYPX))
(COND
((IGREATERP (IPLUS (fetch WORDINPAGE of DTD)
\DTDSize)
(CONSTANT (SUB1 WORDSPERPAGE)))
(* if this is the last one which would fit on a page,
create a new page)
(\NEWPAGE (\ADDBASE DTD \DTDSize)
T)))
(replace DTDNAME of DTD with (\ATOMPNAMEINDEX NAME))
(COND
((NEQ SIZE 0)
(replace DTDSIZE of DTD with SIZE)
(replace DTDDESCRS of DTD with (COPY DESCRIPTORS))
(replace DTDTYPESPECS of DTD with (COPY SPECS))
(replace DTDPTRS of DTD with PTRFIELDS)
(\GCTYPE NTYPX DTD))))
(RETURN NTYPX])
(\ASSIGN.DATATYPE
[LAMBDA (TYPENAME DLIST FIELDSPECS OFFSET) (* lmm "13-Mar-85 16:27")
(COND
(TYPENAME (SETTOPVAL (\TYPEGLOBALVARIABLE TYPENAME)
(ASSIGNDATATYPE TYPENAME DLIST OFFSET FIELDSPECS
(for P in DLIST when (SELECTQ (fetch fdType of P)
((POINTER FULLPOINTER)
T)
NIL)
collect (fetch fdOffset of P])
(\TYPENUMBERFROMNAME
[LAMBDA (TYPE) (* lmm "13-FEB-83 14:09")
(AND TYPE (NEQ TYPE (QUOTE **DEALLOC**))
(for I from 1 to \MaxTypeNumber do (COND
((EQ (\ATOMPNAMEINDEX TYPE)
(fetch DTDNAME of (\GETDTD I)))
(RETURN I])
(CREATECELL
[LAMBDA (TYP) (* lmm "10-DEC-82 15:49")
(\CREATECELL TYP])
(\CREATECELL
[LAMBDA (TYP) (* edited: "16-Dec-84 19:55")
(if (AND (NEQ CDRCODING 0)
(EQ TYP \LISTP))
then (RAID "CREATECELL \LISTP"))
(UNINTERRUPTABLY
(PROG ((DTD (\GETDTD TYP))
NEWCELL)
(SETQ NEWCELL (OR (fetch DTDFREE of DTD)
(\GCTYPE TYP DTD)))
(CHECK (EQ TYP (NTYPX NEWCELL)))
(PROG NIL (* This circumlocution is because replace sometimes
returns a value which can't be NIL-tested in MAKEINIT
mode)
[replace DTDFREE of DTD with (OR (\GETBASEPTR NEWCELL 0)
(PROGN (replace DTDFREE of DTD with NIL)
(RETURN (\GCTYPE TYP DTD]
(* Remember that \GCTYPE will smash the DTDFREE field
with the new page created)
)
(\StatsAdd1 (fetch DTDCNTLOC of DTD))
(PROG ((CNT (fetch DTDSIZE of DTD))
(PTR NEWCELL)) (* Clear object)
(PROGN (\PUTBASE NEWCELL (add CNT -1)
0)
(\BLT NEWCELL (\ADDBASE NEWCELL 1)
CNT)))
(\CREATEREF NEWCELL)
(RETURN NEWCELL)))])
)
(RPAQ? CROSSCOMPILING )
(RPAQ? ASSIGNDATATYPE.ASKUSERWAIT 300)
(RPAQ? \STORAGEFULLSTATE )
(RPAQ? \STORAGEFULL )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL \SYSTEMCACHEVARS \NxtArrayPage)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT)
)
(* fetch and replace)
(DEFINEQ
(FETCHFIELD
[LAMBDA (DESCRIPTOR DATUM) (* edited: " 7-JUN-83 10:23")
(* retrieves a data field from a user data structure.)
(PROG ((TN (fetch fdTypeName of DESCRIPTOR))
(OFFSET (fetch fdOffset of DESCRIPTOR)))
(AND TN (SETQ DATUM (\DTEST DATUM TN)))
(RETURN (SELECTQ (fetch fdType of DESCRIPTOR)
((POINTER XPOINTER FULLPOINTER FULLXPOINTER)
(\GETBASEPTR DATUM OFFSET))
(FLOATP (MAKEFLOATNUMBER (\GETBASE DATUM OFFSET)
(\GETBASE (\ADDBASE DATUM 1)
OFFSET)))
(FIXP (\MAKENUMBER (\GETBASE DATUM OFFSET)
(\GETBASE (ADDBASE DATUM 1)
OFFSET)))
(SWAPPEDFIXP (\MAKENUMBER (\GETBASE (\ADDBASE DATUM 1)
OFFSET)
(\GETBASE DATUM OFFSET)))
(PROG ((FT (fetch fdType of DESCRIPTOR))
(OFF OFFSET))
(RETURN (SELECTQ (CAR FT)
[BITS (LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift (CDR FT)))
(BitFieldMask (CDR FT]
[SIGNEDBITS
([LAMBDA (N WIDTH)
(COND
[[IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH]
(SUB1 (IDIFFERENCE N
(SUB1 (LLSH 1 WIDTH]
(T N]
(LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift (CDR FT)))
(BitFieldMask (CDR FT)))
(BitFieldWidth (CDR FT]
(LONGBITS (\MAKENUMBER
(LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift
(CDR FT)))
(BitFieldMask (CDR FT)))
(\GETBASE (ADDBASE DATUM 1)
OFF)))
(FLAGBITS (NEQ (LOGAND (\GETBASE DATUM OFF)
(BitFieldShiftedMask
(CDR FT)))
0))
(LISPERROR "ILLEGAL ARG" DESCRIPTOR])
(REPLACEFIELD
[LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* lmm " 1-Jan-85 23:09")
(* replace a field in a user data structure.
return coerced value.)
(PROG ((OFFSET (fetch fdOffset of DESCRIPTOR))
(FT (fetch fdType of DESCRIPTOR))
(TN (fetch fdTypeName of DESCRIPTOR))
SHIFT MASK)
(AND TN (SETQ DATUM (\DTEST DATUM TN)))
(RETURN
(SELECTQ
FT
((POINTER FULLPOINTER)
(\RPLPTR DATUM OFFSET NEWVALUE))
(XPOINTER (* no ref count, hi bits used)
(PUTBASEPTRX DATUM OFFSET NEWVALUE))
(FULLXPOINTER (\PUTBASEPTR DATUM OFFSET NEWVALUE))
(FLOATP (\PUTBASEFLOATP DATUM OFFSET NEWVALUE))
(FIXP (\PUTFIXP (\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SWAPPEDFIXP (\PUTSWAPPEDFIXP (\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SELECTQ
(CAR FT)
(BITS (LOGAND (LRSH (\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND NEWVALUE MASK)
SHIFT)))
SHIFT)
MASK))
(SIGNEDBITS
([LAMBDA (X)
(COND
[[IGREATERP X (SUB1 (LLSH 1 (SUB1 (BitFieldWidth (CDR FT]
(SUB1 (IDIFFERENCE X (SUB1 (LLSH 1 (BitFieldWidth (CDR FT]
(T X]
(LOGAND
(LRSH (\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535 (LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND [LOGAND NEWVALUE
(SUB1 (LLSH 1 (BitFieldWidth
(CDR FT]
MASK)
SHIFT)))
SHIFT)
MASK)))
(FLAGBITS (\PUTBASE DATUM OFFSET (LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND (COND
(NEWVALUE 65535)
(T 0))
MASK)
SHIFT)))
(AND NEWVALUE T))
(LONGBITS (PROG (LO HI)
(.UNBOX. NEWVALUE HI LO)
(UNINTERRUPTABLY
(\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND HI MASK)
SHIFT)))
(\PUTBASE DATUM (ADD1 OFFSET)
LO)))
NEWVALUE)
(LISPERROR "ILLEGAL ARG" DESCRIPTOR])
(BOXCOUNT
[LAMBDA (TYPE N) (* lmm "20-OCT-81 20:27")
(PROG [(DTD (\GETDTD (OR (SMALLP TYPE)
(COND
((NULL TYPE)
\FIXP)
(T (\TYPENUMBERFROMNAME TYPE]
(RETURN (PROG1 (fetch DTDCNT of DTD)
(AND (NUMBERP N)
(replace DTDCNT of DTD with N])
(CONSCOUNT
[LAMBDA (N) (* lmm "13-MAY-80 23:02")
(BOXCOUNT \LISTP N])
(\DTEST
[LAMBDA (OBJ TYPE) (* lmm "13-FEB-83 14:09")
(\DTESTFAIL OBJ (\ATOMPNAMEINDEX TYPE])
(\DTESTFAIL
[LAMBDA (OBJ TYPEN) (* lmm "28-Jun-84 14:58")
(* ufn for DTEST opcode)
(COND
((EQ (fetch DTDNAME of (\GETDTD (NTYPX OBJ)))
TYPEN) (* should not happen)
OBJ)
(T (SELECTQ (\INDEXATOMPNAME TYPEN)
(FLOATP (\FLOAT OBJ))
(STREAM (* Should be able to get at the INPUT/OUTPUT flg--a
second arg to \DTEST ?)
(\GETSTREAM OBJ (SELECTQ (STKNTHNAME -1 (QUOTE \DTESTFAIL))
((\BINS \BIN BIN)
(QUOTE INPUT))
((\BOUTS \BOUT BOUT)
(QUOTE OUTPUT))
NIL)))
[HARRAYP (DECLARE (GLOBALVARS SYSHASHARRAY))
(COND
[(NULL OBJ)
(COND
(SYSHASHARRAY (\DTEST SYSHASHARRAY (QUOTE HARRAYP)))
(T (LISPERROR "ARG NOT HARRAY" OBJ T]
((AND (LISTP OBJ)
(TYPENAMEP (CAR OBJ)
(QUOTE HARRAYP)))
(CAR OBJ))
(T (LISPERROR "ARG NOT HARRAY" OBJ T]
(FONTDESCRIPTOR (\COERCEFONTDESC OBJ))
[SMALLP (PROG (HI LO)
(.UNBOX. OBJ HI LO)
(RETURN (OR (SMALLP (\MAKENUMBER HI LO))
(LISPERROR "ILLEGAL ARG" OBJ T]
(LISTP (LISPERROR "ARG NOT LIST" OBJ T))
(LITATOM (LISPERROR "ARG NOT LITATOM" OBJ T))
(STACKP (LISPERROR "ILLEGAL STACK ARG" OBJ T))
(READTABLEP (LISPERROR "ILLEGAL READTABLE" OBJ T))
(TERMTABLEP (LISPERROR "ILLEGAL TERMINAL TABLE" OBJ T))
(ARRAYP (LISPERROR "ARG NOT ARRAY" OBJ T))
(\DISPLAYDATA (* Should be able to get at the stream--a second arg to
\DTEST ?)
(ERROR "ARG NOT DISPLAY STREAM" NIL))
(\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN))
T])
(GETDESCRIPTORS
[LAMBDA (TYPENAME) (* rmk: "28-OCT-81 17:42")
(PROG NIL
(RETURN (COPY (fetch DTDDESCRS of (\GETDTD (COND
((LITATOM TYPENAME)
(OR (\TYPENUMBERFROMNAME TYPENAME)
(RETURN)))
(T (NTYPX TYPENAME])
(GETFIELDSPECS
[LAMBDA (TYPENAME) (* rmk: "28-OCT-81 17:42")
(PROG NIL
(RETURN (COPY (fetch DTDTYPESPECS of (\GETDTD (COND
((LITATOM TYPENAME)
(OR (\TYPENUMBERFROMNAME TYPENAME)
(RETURN)))
(T (NTYPX TYPENAME])
(NCREATE
[LAMBDA (TYPE OLDOBJ) (* lmm "14-MAY-80 08:33")
(NCREATE2 (\TYPENUMBERFROMNAME TYPE)
OLDOBJ])
(NCREATE2
[LAMBDA (NTYPX OLDOBJ) (* bvm: " 5-Feb-85 16:43")
(* a version of NCREATE which has is compiled from calls to NCREATE which have a quoted first arg and an old object.
These can use the TYPE number variable in stead of having to look it up.)
(PROG ((DTD (\GETDTD NTYPX))
(NEW (CREATECELL NTYPX)))
[COND
((EQ (NTYPX OLDOBJ)
NTYPX)
(UNINTERRUPTABLY
(\BLT NEW OLDOBJ (fetch DTDSIZE of DTD))
(for P in (fetch DTDPTRS of DTD) do (\ADDREF (\GETBASEPTR NEW P))))]
(RETURN NEW])
(REPLACEFIELDVAL
[LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(* lmm: "22-AUG-76 04:18:20")
(* used by the record package-- compiles open better than saving datum)
(REPLACEFIELD DESCRIPTOR DATUM NEWVALUE)
DATUM])
(PUTBASEPTRX
[LAMBDA (DATUM OFFSET NEWVALUE)
(* lmm "15-MAY-80 22:20")
(UNINTERRUPTABLY (PUTBASE DATUM OFFSET (LOGOR (LOGAND 177400Q (GETBASE DATUM OFFSET))
(HILOC NEWVALUE)))
(PUTBASE DATUM (ADD1 OFFSET)
(LOLOC NEWVALUE))
NEWVALUE])
(/REPLACEFIELD
[LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(* lmm: "23-AUG-76 00:01:53")
[AND LISPXHIST (UNDOSAVE (LIST (QUOTE /REPLACEFIELD)
DESCRIPTOR DATUM (FETCHFIELD DESCRIPTOR DATUM]
(REPLACEFIELD DESCRIPTOR DATUM NEWVALUE])
(TYPENAME
[LAMBDA (DATUM) (* lmm "13-FEB-83 14:13")
(PROG ((N (NTYPX DATUM)))
(RETURN (SELECTC N
(\ARRAYP (\ARRAYTYPENAME DATUM))
(\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N])
(\TYPENAMEFROMNUMBER
[LAMBDA (N) (* lmm "13-FEB-83 14:13")
(COND
((ILESSP N (ADD1 \MaxTypeNumber))
(\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N])
(\BLOCKDATAP
(LAMBDA (X) (* JonL "22-Sep-84 23:15")
(PROG ((TYPENO (NTYPX X)))
(RETURN (if (EQ 0 TYPENO)
then (type? ARRAYBLOCK X)
else (fetch DTDHUNKP of (\GETDTD TYPENO)))))))
(USERDATATYPES
[LAMBDA NIL (* rrb "16-JUL-80 13:17")
(DATATYPES T])
(DATATYPEP
[LAMBDA (DATATYPESPEC) (* bvm: "12-Feb-85 17:29")
(* returns the type name of a data type spec if it is a
datatype.)
(COND
[(SMALLP DATATYPESPEC)
(PROG ((DTD (\GETDTD DATATYPESPEC))
NAME)
(RETURN (AND (NOT (fetch DTDHUNKP of DTD))
(SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD)))
(NEQ NAME (QUOTE **DEALLOC**))
NAME]
((NOT (LITATOM DATATYPESPEC))
NIL)
((FMEMB DATATYPESPEC (QUOTE (CCODEP HARRAYP))) (* handle subtypes of arrayp specially.)
DATATYPESPEC)
((for I from 1 to \MaxTypeNumber thereis (EQ (\INDEXATOMPNAME (fetch DTDNAME
of (\GETDTD I)))
DATATYPESPEC))
DATATYPESPEC])
(DATATYPES
[LAMBDA (USERSFLG) (* rrb "16-JUL-80 13:20")
(bind N for I from (COND
(USERSFLG (ADD1 \MaxSysTypeNum))
(T 1))
to \MaxTypeNumber when (SETQ N (DATATYPEP I)) collect N])
)
(MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD))
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD))
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL))
(* STORAGE)
(DEFINEQ
(STORAGE
[LAMBDA (TYPES PAGETHRESHOLD) (* bvm: "12-Feb-85 17:22")
(PROG ((TOTALALLOCMDS (CREATECELL \FIXP))
(TOTALHUNKS (CREATECELL \FIXP))
(FREE (CREATECELL \FIXP))
(HUNKSTATS (from 0 to 2 collect (create HUNKSTAT)))
TYPE TYPENAME DOBLOCKSFLG)
(DECLARE (SPECVARS HUNKSTATS))
(printout NIL "Type" 15 "Assigned" 30 "Free items" 45 "In use" 55 "Total alloc" T 15
"pages [items]"
T)
(COND
[(AND TYPES (NEQ TYPES T))
(for TYPE HFLG inside TYPES when [COND
((FIXP TYPE)
(COND
((OR (ILESSP TYPE 0)
(IGREATERP TYPE \MaxTypeNumber))
(* An explicit type number ought to be "right")
(ERROR "Not a type number" TYPE))
((EQ TYPE 0)
(SETQ DOBLOCKSFLG T)
NIL)
(T T)))
(T (SETQ TYPE (\TYPENUMBERFROMNAME TYPE]
do (COND
((fetch DTDHUNKP of (\GETDTD TYPE))
(SETQ HFLG T)))
(\STORAGE.TYPE TYPE FREE TOTALALLOCMDS PAGETHRESHOLD)
finally (COND
(HFLG (\STORAGE.HUNKTYPE TOTALALLOCMDS PAGETHRESHOLD]
(T (for I from 1 to \MaxTypeNumber do (\STORAGE.TYPE I FREE TOTALALLOCMDS PAGETHRESHOLD))
(\STORAGE.HUNKTYPE TOTALHUNKS PAGETHRESHOLD)
(printout NIL T "TOTAL" 15 .I5 (IPLUS TOTALALLOCMDS TOTALHUNKS)
T T)
(printout NIL "Data Spaces Summary" T)
(printout NIL 30 "Allocated" 50 "Remaining" T)
(printout NIL 32 "Pages" 52 "Pages" T)
(printout NIL "Datatypes (incl. LISTP etc.)" 30 .I8 TOTALALLOCMDS 50 "\" T)
(* Arrayspace and MDS come out of the same pot, so lump
their "remaining" pages together)
(printout NIL "ArrayBlocks" (COND
((NOT (IEQP TOTALHUNKS 0))
" (variable)")
(T ""))
30 .I8 (SELECTC \STORAGEFULLSTATE
((LIST \SFS.FULLYSWITCHED \SFS.ARRAYSWITCHED)
(IPLUS (IDIFFERENCE \LeastMDSPage \FirstArrayPage)
(IDIFFERENCE \NxtArrayPage \SecondArrayPage)))
(IDIFFERENCE \NxtArrayPage \FirstArrayPage))
50 "--" .I6 (CAR (STORAGE.LEFT))
T)
(COND
((NOT (IEQP TOTALHUNKS 0))
(printout NIL "ArrayBlocks (chunked)" 30 .I8 TOTALHUNKS 50 "/" T)))
(* \LastATOMpage marks off atom indexes as if they were word addresses; but the space behind a litatom is one cell
in each of the four spaces: DEFSPACE, VALSPACE, PNAMESPACE, and PROPSPACE)
(\STLINP "Litatoms" (ITIMES (FOLDHI \AtomFrLst CELLSPERPAGE)
4)
(ITIMES (UNFOLD (ADD1 \LastAtomPage)
WORDSPERCELL)
4))
(COND
(\PNAMES.IN.BLOCKS? (\STLINP "Litatom Pnames (from bootstrap)" (ADD1 \CurPnPage)
(ADD1 \CurPnPage)))
(T (\STLINP "Litatom Pnames" (ADD1 \CurPnPage)
\LastPnPage)))
(SETQ DOBLOCKSFLG T)))
(COND
(DOBLOCKSFLG (\SHOW.ARRAY.FREELISTS])
(STORAGE.LEFT
[LAMBDA NIL (* bvm: "16-Jan-85 12:30")
(* * Return a list MDS+Arrays left in 8mb, in 24mb, litatoms left, pnames left and the same as fractions)
(PROG ((MDSFREE (IPLUS (FOLDLO \MDSIncrement PAGESPERSEGMENT)
(IDIFFERENCE (SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
(\SFS.ARRAYSWITCHED
(* There's free space in two places: some leftover MDS
in the lo region, and the space beyond allocated arrays
in the hi)
\SecondMDSPage)
\NxtMDSPage)
\NxtArrayPage)
(SELECTC \STORAGEFULLSTATE
(\SFS.SWITCHABLE (* We have another 24MB to work with)
(IPLUS (IDIFFERENCE \SecondMDSPage
\SecondArrayPage)
(FOLDLO \MDSIncrement PAGESPERSEGMENT)))
(\SFS.ARRAYSWITCHED (* Account for the space left behind after array
allocation moved)
(IPLUS (IDIFFERENCE \NxtMDSPage \LeastMDSPage)
(FOLDLO \MDSIncrement PAGESPERSEGMENT))
)
0)
(for (FREE ← \MDSFREELISTPAGE)
by (SMALLP (\GETBASEPTR (create POINTER
PAGE# ← FREE)
0))
while FREE sum 1)))
(ATOMTOTAL (ITIMES (UNFOLD (ADD1 \LastAtomPage)
WORDSPERCELL)
4))
ATOMSLEFT MDSFRAC)
[SETQ MDSFRAC (FQUOTIENT MDSFREE (IPLUS (IDIFFERENCE (IPLUS \FirstMDSPage (FOLDLO
\MDSIncrement
PAGESPERSEGMENT))
\FirstArrayPage)
(COND
((EQ \STORAGEFULLSTATE \SFS.NOTSWITCHABLE)
0)
(T (IDIFFERENCE (IPLUS \SecondMDSPage
(FOLDLO \MDSIncrement
PAGESPERSEGMENT))
\SecondArrayPage]
(RETURN (LIST MDSFREE MDSFRAC (SELECTC \STORAGEFULLSTATE
(\SFS.NOTSWITCHABLE MDSFRAC)
(\SFS.SWITCHABLE (FQUOTIENT
(IDIFFERENCE (IPLUS \NxtMDSPage
(FOLDLO
\MDSIncrement
PAGESPERSEGMENT))
\NxtArrayPage)
(IDIFFERENCE (IPLUS \FirstMDSPage
(FOLDLO
\MDSIncrement
PAGESPERSEGMENT))
\FirstArrayPage)))
0)
(SETQ ATOMSLEFT (IDIFFERENCE ATOMTOTAL (ITIMES (FOLDHI \AtomFrLst
CELLSPERPAGE)
4)))
(FQUOTIENT ATOMSLEFT ATOMTOTAL])
(\STORAGE.TYPE
[LAMBDA (TYPE FREE TOTALALLOCMDS PAGETHRESHOLD) (* bvm: "12-Feb-85 17:06")
(DECLARE (USEDFREE HUNKSTATS))
(PROG ((ALLOCMDS 0)
SIZE NAME ALLOC INUSE ITEMSPERMDS INUSEPAGES NPAGESALLOCATED HUNKP DTD STAT)
(DECLARE (SPECVARS ALLOCMDS))
(SETQ DTD (\GETDTD TYPE))
(OR (SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD)))
(RETURN))
(SETQ HUNKP (fetch DTDHUNKP of DTD))
(SETQ SIZE (fetch DTDSIZE of DTD))
(CHECK (EVENP SIZE WORDSPERCELL))
(SETQ ITEMSPERMDS (SELECTQ NAME
((LITATOM SMALLP)
(RETURN))
[LISTP (COND
((EQ CDRCODING 0)
(IQUOTIENT \MDSIncrement SIZE))
(T (CONSTANT (FIX (FQUOTIENT \MDSIncrement 2.2]
(IQUOTIENT \MDSIncrement SIZE)))
[\MAPMDS TYPE (FUNCTION (LAMBDA NIL
(add ALLOCMDS 1]
(SETQ NPAGESALLOCATED (ITIMES ALLOCMDS (IQUOTIENT \MDSIncrement WORDSPERPAGE)))
(COND
((SETQ HUNKP (fetch DTDHUNKP of DTD))
(add [fetch (HUNKSTAT NPAGES) of (SETQ STAT (CAR (NTH HUNKSTATS
(ADD1 (fetch DTDGCTYPE
of DTD]
NPAGESALLOCATED))
(T (\BOXIPLUS TOTALALLOCMDS NPAGESALLOCATED)))
(COND
((AND PAGETHRESHOLD (ILESSP NPAGESALLOCATED PAGETHRESHOLD))
(RETURN)))
(\PUTBASEFIXP (\DTEST FREE (QUOTE FIXP))
0 0)
[COND
[(AND (NEQ CDRCODING 0)
(EQ TYPE \LISTP))
(for (LSTPAG ←(create POINTER
PAGE# ←(fetch DTDNEXTPAGE of \LISTPDTD)))
by (create POINTER
PAGE# ←(fetch (CONSPAGE NEXTPAGE) of LSTPAG))
while LSTPAG do (\BOXIPLUS FREE (fetch (CONSPAGE CNT) of LSTPAG]
(T (for (PTR ←(fetch DTDFREE of DTD)) by (\GETBASEPTR PTR 0) while PTR
do (CHECK (EQ (NTYPX PTR)
TYPE)
(EVENP (IMOD (\LOLOC PTR)
\MDSIncrement)
SIZE))
(\BOXIPLUS FREE 1]
(SETQ INUSE (IDIFFERENCE (SETQ ALLOC (ITIMES ALLOCMDS ITEMSPERMDS))
FREE))
(COND
((fetch DTDHUNKP of DTD) (* Keep a cumulative table to be printed out at the end
of this all by \STORAGE.HUNKTYPE)
(add (fetch (HUNKSTAT NITEMS) of STAT)
ALLOC)
(add (fetch (HUNKSTAT NFREE) of STAT)
FREE)
(add (fetch (HUNKSTAT NINUSE) of STAT)
INUSE)
(add (fetch (HUNKSTAT NALLOCATED) of STAT)
(BOXCOUNT TYPE)))
(T (\STMDSTYPE (SELECTQ NAME
(LISTP "LISTP ~")
NAME)
NPAGESALLOCATED ALLOC FREE INUSE (BOXCOUNT TYPE])
(\STLINP
[LAMBDA (STR ALLOC TOT) (* bvm: " 9-Feb-85 15:23")
(printout NIL STR 30 .I8 ALLOC 50 .I8 (IDIFFERENCE TOT ALLOC)
T])
(\STMDSTYPE
(LAMBDA (NAME NPAGESALLOCATED ALLOC FREE INUSE BOXCOUNT) (* JonL "22-Sep-84 22:41")
(printout NIL NAME 15 .I5 NPAGESALLOCATED .I8 ALLOC 30 .I8 FREE 43 .I8 INUSE 56 .I10 BOXCOUNT T)))
(\STORAGE.HUNKTYPE
[LAMBDA (TOTAL PAGETHRESHOLD) (* bvm: "12-Feb-85 17:03")
(DECLARE (USEDFREE HUNKSTATS))
(PROG (NPAGESALLOCATED STAT)
(for GCTYPE.NAME in [CONSTANT (LIST (LIST UNBOXEDBLOCK.GCT (QUOTE UNBOXEDHUNK))
(LIST PTRBLOCK.GCT (QUOTE PTRHUNK))
(LIST CODEBLOCK.GCT (QUOTE CODEHUNK]
do [SETQ STAT (CAR (NTH HUNKSTATS (ADD1 (CAR GCTYPE.NAME]
(SETQ NPAGESALLOCATED (fetch (HUNKSTAT NPAGES) of STAT))
(\BOXIPLUS TOTAL NPAGESALLOCATED)
(COND
((AND (NEQ NPAGESALLOCATED 0)
(OR (NOT PAGETHRESHOLD)
(IGEQ NPAGESALLOCATED PAGETHRESHOLD)))
(\STMDSTYPE (CADR GCTYPE.NAME)
NPAGESALLOCATED
(fetch (HUNKSTAT NITEMS) of STAT)
(fetch (HUNKSTAT NFREE) of STAT)
(fetch (HUNKSTAT NINUSE) of STAT)
(fetch (HUNKSTAT NALLOCATED) of STAT])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD HUNKSTAT (NPAGES NITEMS NFREE NINUSE NALLOCATED)
NPAGES ← 0 NITEMS ← 0 NFREE ← 0 NINUSE ← 0 NALLOCATED ← 0)
]
)
(RPAQ? STORAGE.ARRAYSIZES (QUOTE (4 16 64 256 1024 4096 16384 NIL)))
(DECLARE:
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS PUTBASEPTRX MACRO (OPENLAMBDA (DATUM OFFSET NEWVALUE)
(UNINTERRUPTABLY
(\PUTBASEBYTE DATUM (ADD1 (LLSH OFFSET 1))
(LOGAND (\HILOC NEWVALUE)
255))
(\PUTBASE DATUM (ADD1 OFFSET)
(\LOLOC NEWVALUE))
NEWVALUE)))
)
(* END EXPORTED DEFINITIONS)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(RPAQQ \SMALLP 1)
(RPAQQ \FIXP 2)
(RPAQQ \FLOATP 3)
(RPAQQ \LITATOM 4)
(RPAQQ \LISTP 5)
(RPAQQ \ARRAYP 6)
(RPAQQ \STRINGP 7)
(RPAQQ \STACKP 8)
(RPAQQ \VMEMPAGEP 10)
(RPAQQ \STREAM 11)
(CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP \VMEMPAGEP \STREAM)
)
(* END EXPORTED DEFINITIONS)
DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD DTD ((DTDNAME WORD)
(DTDSIZE WORD)
(DTDFREE FULLXPOINTER)
(NIL BITS 4)
(DTDLOCKEDP FLAG)
(DTDHUNKP FLAG)
(DTDGCTYPE BITS 2) (* Only for hunk datatypes -- like arrayblock's GCTYPE)
(DTDDESCRS POINTER)
(DTDTYPESPECS POINTER)
(DTDPTRS POINTER)
(DTDOLDCNT FIXP)
(DTDCNT0 WORD)
(DTDNEXTPAGE WORD))
[ACCESSFNS DTD ((DTDCNTLOC (\ADDBASE DATUM 10))
(DTDCNT (IPLUS (fetch DTDOLDCNT DATUM)
(fetch DTDCNT0 DATUM))
(UNINTERRUPTABLY
(replace DTDCNT0 of DATUM with 0)
(replace DTDOLDCNT of DATUM with NEWVALUE))])
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETDTD MACRO ((typeNum)
(ADDBASE \DTDSpaceBase (LLSH typeNum 4))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \GUARDSTORAGEFULL 128)
(RPAQQ \GUARD1STORAGEFULL 64)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NxtMDSPage \LeastMDSPage \MDSFREELISTPAGE \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL
\INTERRUPTSTATE \PENDINGINTERRUPT)
)
(* END EXPORTED DEFINITIONS)
(RPAQQ STORAGEFULLSTATES ((\SFS.NORMAL NIL)
(\SFS.NOTSWITCHABLE 1)
(\SFS.SWITCHABLE 2)
(\SFS.ARRAYSWITCHED 3)
(\SFS.FULLYSWITCHED 4)))
(DECLARE: EVAL@COMPILE
(RPAQQ \SFS.NORMAL NIL)
(RPAQQ \SFS.NOTSWITCHABLE 1)
(RPAQQ \SFS.SWITCHABLE 2)
(RPAQQ \SFS.ARRAYSWITCHED 3)
(RPAQQ \SFS.FULLYSWITCHED 4)
(CONSTANTS (\SFS.NORMAL NIL)
(\SFS.NOTSWITCHABLE 1)
(\SFS.SWITCHABLE 2)
(\SFS.ARRAYSWITCHED 3)
(\SFS.FULLYSWITCHED 4))
)
(RPAQQ DTDECLS ((SMALLP)
(FIXP 2)
(FLOATP 2)
(LITATOM)
(LISTP 4 0 2)
(ARRAYP 4 0)
(STRINGP 4 0)
(STACKP 2)
(NIL 4 0)
(VMEMPAGEP 256)))
)
(* for MAKEINIT)
(DEFINEQ
(CREATEMDSTYPETABLE
[LAMBDA NIL (* bvm: "12-Dec-84 14:24")
(* called only under MAKEINIT to initialize the main
data space type table)
(CREATEPAGES \MDSTypeTable \MDSTTsize NIL T)
[PROG (VP)
(* * FIRST SET ALL TO NOREF)
(SETQ VP 0)
(FRPTQ (UNFOLD \MDSTTsize WORDSPERPAGE)
(\PUTBASE \MDSTypeTable VP \TT.NOREF)
(add VP 1))
(* * NOW SET UP SMALLPS)
(for SEGMENT in (LIST \SmallPosHi \SmallNegHi)
do (for PAGE from 0 to (SUB1 PAGESPERSEGMENT) by (FOLDLO \MDSIncrement WORDSPERPAGE)
do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD SEGMENT PAGESPERSEGMENT))
(LOGOR \TT.NOREF \SMALLP]
(CREATEPAGES \MISCSTATS (FOLDLO \MDSIncrement WORDSPERPAGE)
NIL T)
(\MAKEMDSENTRY (PAGELOC \MISCSTATS)
(LOGOR \TT.NOREF \FIXP])
(INITDATATYPES
[LAMBDA NIL (* bvm: "12-Dec-84 14:03")
(* called only under MAKEINIT;
called before it is possible to make new atoms)
(SETQ \MaxTypeNumber 0)
(CREATEPAGES \DTDSpaceBase 1 NIL T)
[for D in (LOCAL DTDECLS) bind DTD as old \MaxTypeNumber from 1
do (COND
((AND (CAR D)
(CADR D))
(replace DTDSIZE of (SETQ DTD (\GETDTD \MaxTypeNumber)) with (LOCAL (CADR D)))
(\GCTYPE \MaxTypeNumber DTD]
[COND
((NEQ CDRCODING 0)
(SETQ.NOREF \LISTPDTD (\GETDTD \LISTP]
NIL])
(INITDATATYPENAMES
[LAMBDA NIL (* lmm "13-Mar-85 16:28")
(* called in MAKEINIT after it is ok to create new
atoms to REALLY initialize the data type tables -
\MaxSysTypeNum is in INITVALUES)
(SETQ \MaxSysTypeNum (SETQ \MaxTypeNumber 0)) (* start over at the beginning)
[for D in (LOCAL DTDECLS)
do (* redeclare with atoms in right places)
(\ASSIGNDATATYPE1 (LOCAL (CAR D))
NIL
(OR (LOCAL (CADR D))
0)
NIL
(COPY (LOCAL (CDDR D]
(SETQ \MaxSysTypeNum \MaxTypeNumber])
)
(DECLARE: DONTCOPY
(ADDTOVAR INITVALUES (\NxtMDSPage \FirstMDSPage)
(\LeastMDSPage \FirstMDSPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(ADDTOVAR INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE \ASSIGNDATATYPE1
\TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS DTDECLS))
(ADDTOVAR RDCOMS (FNS NTYPX TYPENAME))
(ADDTOVAR RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X)
(QUOTE ARRAYP)))
(ADDTOVAR EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS \PUTBITS \TESTBITS
GETBASEBITS PUTBASEBITS FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL
REPLACEFIELDVAL NCREATE)
(ADDTOVAR MKI.SUBFNS (\GCDISABLED . NILL)
(CREATECELL . I.\CREATECELL)
(\CHECKFORSTORAGEFULL . NILL))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
DTDECLARE)
)
(PUTPROPS LLDATATYPE COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3315 21076 (NTYPX 3325 . 3749) (\ALLOCMDSPAGE 3751 . 5064) (\ALLOCPAGEBLOCK 5066 . 6509
) (\MAPMDS 6511 . 8049) (\CHECKFORSTORAGEFULL 8051 . 11872) (\DOSTORAGEFULLINTERRUPT 11874 . 12204) (
\SET.STORAGE.STATE 12206 . 12832) (\ADVANCE.STORAGE.STATE 12834 . 13380) (\NEW2PAGE 13382 . 13549) (
\MAKEMDSENTRY 13551 . 13685) (\GCTYPE 13687 . 14303) (\INITMDSPAGE 14305 . 15998) (\ASSIGNDATATYPE1
16000 . 18800) (\ASSIGN.DATATYPE 18802 . 19260) (\TYPENUMBERFROMNAME 19262 . 19561) (CREATECELL 19563
. 19696) (\CREATECELL 19698 . 21074)) (21441 33536 (FETCHFIELD 21451 . 23320) (REPLACEFIELD 23322 .
26672) (BOXCOUNT 26674 . 27017) (CONSCOUNT 27019 . 27125) (\DTEST 27127 . 27251) (\DTESTFAIL 27253 .
29122) (GETDESCRIPTORS 29124 . 29460) (GETFIELDSPECS 29462 . 29791) (NCREATE 29793 . 29929) (NCREATE2
29931 . 30609) (REPLACEFIELDVAL 30611 . 30908) (PUTBASEPTRX 30910 . 31221) (/REPLACEFIELD 31223 .
31511) (TYPENAME 31513 . 31755) (\TYPENAMEFROMNUMBER 31757 . 31953) (\BLOCKDATAP 31955 . 32257) (
USERDATATYPES 32259 . 32363) (DATATYPEP 32365 . 33285) (DATATYPES 33287 . 33534)) (33733 44140 (
STORAGE 33743 . 37059) (STORAGE.LEFT 37061 . 39708) (\STORAGE.TYPE 39710 . 42719) (\STLINP 42721 .
42910) (\STMDSTYPE 42912 . 43126) (\STORAGE.HUNKTYPE 43128 . 44138)) (47199 49777 (CREATEMDSTYPETABLE
47209 . 48238) (INITDATATYPES 48240 . 48982) (INITDATATYPENAMES 48984 . 49775)))))
STOP