(FILECREATED " 3-Oct-86 18:03:29" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;75 88375
changes to: (FNS \TYPENUMBERFROMNAME \DTEST.UFN)
previous date: "26-Sep-86 18:48:49" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;74)
(* "
Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LLDATATYPECOMS)
(RPAQQ LLDATATYPECOMS
((COMS (* ; "Storage management")
(FNS NTYPX \TYPEMASK.UFN \TYPEP.UFN \ALLOCMDSPAGE \ALLOCPAGEBLOCK
\ALLOCVIRTUALPAGEBLOCK \MAPMDS \CHECKFORSTORAGEFULL \DOSTORAGEFULLINTERRUPT
\SET.STORAGE.STATE \SETTYPEMASK \ADVANCE.STORAGE.STATE \NEW2PAGE \MAKEMDSENTRY
\INITMDSPAGE \ASSIGNDATATYPE1 \RESOLVE.TYPENUMBER \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 \TYPECHECK \DTEST.UFN
\INSTANCEP.UFN \INSTANCE-P \TYPECHECK.UFN GETDESCRIPTORS GETSUPERTYPE
GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL PUTBASEPTRX /REPLACEFIELD TYPENAME
TYPENAMEP \TYPENAMEFROMNUMBER \BLOCKDATAP USERDATATYPES DATATYPEP DATATYPES)
(P (MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD)
NIL T)
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD)
NIL T)
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL)
NIL T))
(DECLARE: (EXPORT (OPTIMIZERS TYPENAMEP \INSTANCE-P))))
(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 (OPTIMIZERS PUTBASEPTRX)
(CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP
\VMEMPAGEP \STREAM)
(VARS \BUILT-IN-SYSTEM-TYPES))
DONTCOPY
(EXPORT (RECORDS DTD)
(MACROS \GETDTD \TYPEMASK.UFN)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
(GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage
\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)
(\SecondMDSPage \DefaultSecondMDSPage)
(\SecondArrayPage \DefaultSecondArrayPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \INITMDSPAGE
\ASSIGNDATATYPE1 \TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE
)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS \BUILT-IN-SYSTEM-TYPES))
(RDCOMS (FNS NTYPX TYPENAME \TYPENAMEFROMNUMBER))
(RDVALS (\MaxTypeNumber))
(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)
(PROP FILETYPE LLDATATYPE)
(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])
(\TYPEMASK.UFN
[LAMBDA (X N) (* lmm "22-Mar-85 16:37")
(COND
((NEQ 0 (LOGAND N (LRSH [\GETBASE \MDSTypeTable (FOLDLO (fetch (POINTER PAGE#) of X)
(CONSTANT (IQUOTIENT \MDSIncrement
WORDSPERPAGE]
8)))
X])
(\TYPEP.UFN
[LAMBDA (X N) (* lmm "22-Mar-85 10:07")
(COND
((EQ (NTYPX X)
N)
X])
(\ALLOCMDSPAGE
[LAMBDA (TYP) (* lmm "27-Mar-85 09:16")
(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 TYP)
(RETURN VPTR])
(\ALLOCPAGEBLOCK
[LAMBDA (NPAGES) (* ejs: "11-Aug-85 15:02")
(UNINTERRUPTABLY
(* * Allocates a continguous chunk of NPAGES pages.
Currently there is no provision for giving them back.)
(LET ((RESULT (\ALLOCVIRTUALPAGEBLOCK NPAGES)))
(COND
(RESULT (to NPAGES as (BASE ← RESULT) by (\ADDBASE BASE WORDSPERPAGE)
do (* Allocate the new pages.
Leave them having the default type,
namely type 0, don't refcnt)
(\NEWPAGE BASE))
RESULT))))])
(\ALLOCVIRTUALPAGEBLOCK
[LAMBDA (NPAGES) (* ejs: "11-Aug-85 13:49")
(UNINTERRUPTABLY
(* * Allocates a continguous chunk of NPAGES virtual pages.
Does not actually allocate the memory, just removes them from the set of pages
that the allocator will use)
(PROG (FIRSTPAGE)
(COND
([ILEQ (IPLUS \NxtArrayPage \GUARDSTORAGEFULL)
(SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \NxtMDSPage \PagesPerMDSUnit)
(SETQ NPAGES (CEIL NPAGES \PagesPerMDSUnit]
(* Plenty of space)
(SETQ \NxtMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
[(NEQ (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
\SFS.SWITCHABLE)
(COND
([AND (EQ \STORAGEFULLSTATE \SFS.ARRAYSWITCHED)
(ILESSP (IPLUS \SecondArrayPage \GUARDSTORAGEFULL)
(SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \SecondMDSPage \PagesPerMDSUnit
)
NPAGES]
(* Arrays have been switched, but we're still allocating MDS in low space.
Just bump the variable that says where MDS in high space will start)
(SETQ \SecondMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
(T (* Can't switch to the higher area)
(RETURN NIL]
((ILESSP \NxtArrayPage FIRSTPAGE) (* Safe to go ahead anyway.
We'll be pretty short of space in the
first 8mb, but it's switchable)
(SETQ \NxtMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
((ILESSP (IPLUS (SETQ FIRSTPAGE \SecondArrayPage)
NPAGES)
\SecondMDSPage) (* There is space in upper area.
So advance the pointer that says where
array space will start when we switch
later on)
(SETQ \SecondArrayPage (IPLUS FIRSTPAGE NPAGES))
(replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535))
(T (RETURN NIL)))
(RETURN (create POINTER
PAGE# ← FIRSTPAGE))))])
(\MAPMDS
[LAMBDA (TYPE FN) (* bvm: "24-Apr-85 14:29")
(* * 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)
\DefaultSecondArrayPage)
(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: "24-Apr-85 15:00")
(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)
\PagesPerMDSUnit))
\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: "12-Aug-85 14:46")
(PROG1 (SETQ \STORAGEFULLSTATE (COND
((SELECTC \MACHINETYPE
(\DOLPHIN NIL)
(\DANDELION (NEQ 0 (fetch (IFPAGE DL24BitAddressable)
of \InterfacePage)))
T) (* we can use high addresses)
\SFS.SWITCHABLE)
(T \SFS.NOTSWITCHABLE)))
(push \SYSTEMCACHEVARS (QUOTE \STORAGEFULLSTATE)) (* Want to recompute this if we come
back from logout)
])
(\SETTYPEMASK
[LAMBDA (NTYPX BITS)
(PROG ((DTD (\GETDTD NTYPX)))
(change (fetch DTDTYPEENTRY of DTD)
(LOGOR DATUM BITS))
(\MAPMDS NTYPX (FUNCTION (LAMBDA (PAGE)
(\PUTBASE \MDSTypeTable (SETQ PAGE (FOLDLO PAGE (IQUOTIENT
\MDSIncrement
WORDSPERPAGE)))
(LOGOR (\GETBASE \MDSTypeTable PAGE)
BITS])
(\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) (* bvm: " 8-Sep-85 14:17")
(\PUTBASE \MDSTypeTable (LRSH VP 1)
(COND
((\GCDISABLED)
(LOGOR \TT.NOREF V))
(T V])
(\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 SUPERTYPE) (* gbn "26-Sep-86 18:16")
(* * "Declare type NAME to have the indicated DESCRIPTORS, SIZE (in words), SPECS (type specifiers for FETCHFIELD), PTRFIELDS (list of offsets of fields that contain reference-counted pointers) and SUPERTYPE (a type number that shares an initial prefix of DESCRIPTORS with us, or NIL). Returns two values: the type number assigned, and whether the type was redeclared in the process.")
(PROG ((NTYPX (\TYPENUMBERFROMNAME NAME))
(SUPERTYPENUMBER (COND
(SUPERTYPE (OR (\TYPENUMBERFROMNAME SUPERTYPE)
(ERROR SUPERTYPE
":INCLUDEd datatype but not currently declared")
))
(T 0)))
DTD REDECLARED NEWTYPENUM NEWDTD)
(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 DTDSUPERTYPE of DTD with SUPERTYPENUMBER)
(RETURN NTYPX))
((EQ (fetch DTDSIZE of DTD)
0) (*
"Type name to number is assigned, but no declaration yet -- proceed to allocate this type number")
)
((OR (EQ CROSSCOMPILING T)
(AND CROSSCOMPILING (NEQ (QUOTE Y)
(ASKUSER 30 (SELECTQ CROSSCOMPILING
(Y (QUOTE Y))
(QUOTE N))
(LIST (COND
(SIZE
"OK TO REDECLARE DATATYPE "
)
(T "OK to deallocate DATATYPE ")
)
NAME)))))
(* don't redeclare)
(RETURN NTYPX))
((IGREATERP NTYPX \MaxSysTypeNum) (*
"Can redeclare 'user' types, i.e., anything not in the makeinit")
(SETQ REDECLARED T))
(T (* can't mess with sys types)
(ERROR "ILLEGAL DATA TYPE" NAME)))))
(* "If we get this far, we're about to create a for-real new datatype (we may need to deallocate the old version of this one...)")
(COND
((NOT SIZE) (* only called to deallocate old
datatype)
)
(T (COND
((AND (EQ \MaxTypeNumber \EndTypeNumber)
(OR (NULL NTYPX)
REDECLARED))
(LISPERROR "DATA TYPES FULL" NAME)))
(UNINTERRUPTABLY
(COND
((OR (NULL NTYPX)
REDECLARED) (*
"Bump the global count of types assigned, and grab the latest.")
(SETQ NEWTYPENUM (add \MaxTypeNumber 1))
(SETQ NEWDTD (\GETDTD NEWTYPENUM)) (* Build a new DTD for it.)
(COND
((IGEQ (IPLUS (fetch WORDINPAGE of NEWDTD)
\DTDSize)
WORDSPERPAGE) (* if this is the last one which would
fit on a page, create a new page)
(\NEWPAGE (\ADDBASE NEWDTD \DTDSize)
T)))
(COND
(REDECLARED (* "When redeclaring a datatype, have to change the type of all old instances to be a new obsoleted type so that the garbage collector will still collect them properly. Keep the original type number, because the name -> type number mapping has already happened to compiled code")
(LET ((NEWTYPEENTRY (LOGOR NEWTYPENUM (LOGAND (fetch DTDTYPEENTRY
of DTD)
(LOGNOT \TT.TYPEMASK))
))
FOUNDSOME)
(\MAPMDS NTYPX (FUNCTION (LAMBDA (PAGE)
(\MAKEMDSENTRY PAGE NEWTYPEENTRY)
(SETQ FOUNDSOME T))))
(COND
((NOT FOUNDSOME) (* "Optimization: if no objects of the old type have been allocated (or all have been reclaimed and the pages detyped), then don't need a new type number for them")
(add \MaxTypeNumber -1))
(T (replace DTDDESCRS of DTD with NIL)
(replace DTDTYPESPECS of DTD with NIL)
(\BLT NEWDTD DTD \DTDSize)
(* "Copy old DTD to new. Be careful about the pointer fields -- we haven't incremented their reference counts. Those fields are DTDDESCRS, DTDTYPESPECS and DTDPTRS, the first two of which we have conveniently smashed to NIL before copying.")
(\ADDREF (fetch DTDPTRS of NEWDTD))
(replace DTDOBSOLETE of NEWDTD with T)
(replace DTDTYPEENTRY of NEWDTD with NEWTYPEENTRY)
(replace DTDNAME of NEWDTD
with (\ATOMPNAMEINDEX (PACK* "Obsolete-" NAME)))
(replace DTDFREE of DTD with NIL)
(*
"Replacement type has no free list--just the old type, now in NEWDTD")
))))
(T (* "Normal case of a new type")
(SETQ NTYPX NEWTYPENUM)
(replace DTDNAME of (SETQ DTD NEWDTD) with (\ATOMPNAMEINDEX NAME))))))
(COND
((NEQ SIZE 0) (* If the datum takes up any space,
remember what it looks like inside)
(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)
(replace DTDSUPERTYPE of DTD with SUPERTYPENUMBER)
(replace DTDTYPEENTRY of DTD with NTYPX)
(* The type-masked type#, for fast
type checking)
))
(* * "NOTE: If the redeclared type has subtypes, we have to redeclare them, too!")
)
(RETURN (VALUES NTYPX REDECLARED)))))))
(\RESOLVE.TYPENUMBER
[LAMBDA (TYPENAME) (* bvm: "13-Jun-86 16:11")
(* * "For the loader. Returns a type number for TYPENAME, possibly allocating a new type number (but not declaring it) if the type does not yet exist.")
(COND
((AND TYPENAME (LITATOM TYPENAME))
(OR (\TYPENUMBERFROMNAME TYPENAME)
(\ASSIGNDATATYPE1 TYPENAME NIL 0)))
(T (\ILLEGAL.ARG TYPENAME])
(\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) (* gbn " 2-Oct-86 15:19")
(AND TYPE (BIND (INDEX ← (\ATOMPNAMEINDEX TYPE)) for I from 1 to \MaxTypeNumber
do (COND
((EQ INDEX (fetch DTDNAME of (\GETDTD I)))
(RETURN I)))))))
(CREATECELL
[LAMBDA (TYP) (* lmm "10-DEC-82 15:49")
(\CREATECELL TYP])
(\CREATECELL
[LAMBDA (TYP) (* bvm: " 4-Jun-86 16:43")
(COND
((AND (NEQ CDRCODING 0)
(EQ TYP \LISTP))
(RAID "CREATECELL \LISTP")))
(LET ((DTD (\GETDTD TYP))
NEWCELL)
(while (EQ (fetch DTDSIZE of DTD)
0) do (ERROR "Attempt to CREATE a type not declared yet" (\TYPENAMEFROMNUMBER
TYP)))
(UNINTERRUPTABLY
(COND
((SETQ NEWCELL (fetch DTDFREE of DTD))
(CHECK (EQ TYP (NTYPX NEWCELL)))
(replace DTDFREE of DTD with (\GETBASEPTR NEWCELL 0))
(\StatsAdd1 (LOCF (fetch DTDOLDCNT of DTD)))
(LET [(CNT (SUB1 (fetch DTDSIZE of DTD] (* Clear object)
(\PUTBASE NEWCELL CNT 0)
(\BLT NEWCELL (\ADDBASE NEWCELL 1)
CNT))
(\CREATEREF NEWCELL)
NEWCELL)
(T (* "Free list exhausted. Replenish it, then do a CREATECELL, hopefully getting the microcode to do most of the work.")
(* * "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.
Don't understand this remark -- if CREATECELL gets called for this type before we have stored DTDFREE then are we just hoping the recursion eventually stops? Remark might apply for the old implementation where CREATECELL for a random type fixes everyone's free list, but again I'm not sure why. -bvm 5/86")
(replace DTDFREE of DTD with (\INITMDSPAGE (\ALLOCMDSPAGE (fetch DTDTYPEENTRY
of DTD))
(fetch DTDSIZE of DTD)
(fetch DTDFREE of DTD)))
(CREATECELL TYP))))])
)
(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 "22-Mar-85 12:29")
(\DTEST.UFN OBJ (\ATOMPNAMEINDEX TYPE])
(\TYPECHECK
[LAMBDA (OBJ TYPE) (* lmm "22-Mar-85 12:29")
(\DTEST.UFN OBJ (\ATOMPNAMEINDEX TYPE])
(\DTEST.UFN
(LAMBDA (OBJ TYPEN) (* gbn " 3-Oct-86 10:49")
(* ;; "ufn for DTEST opcode ")
(* ;; "coerce into desired type")
(PROG ((N (NTYPX OBJ)))
LP (COND
((EQ (fetch DTDNAME of (\GETDTD N))
TYPEN) (* ; "should be happening in microcode")
(RETURN OBJ))
((NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N))))
(GO LP))
(T (RETURN (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 \DTEST.UFN))
((\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))))))))
(\INSTANCEP.UFN
[LAMBDA (OBJ TYPEN) (* gbn "23-Sep-86 19:19")
(* ;;; "ufn for INSTANCEP opcode")
(PROG ((N (NTYPX OBJ)))
LP (COND
((EQ (fetch DTDNAME of (\GETDTD N))
TYPEN)
(RETURN T))
([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N]
(* ;; "recur on the supertype")
(GO LP))
(T (RETURN NIL])
(\INSTANCE-P
(LAMBDA (OBJECT TYPE) (* gbn "26-Sep-86 17:07")
(* ;;
"should be phased out in favor of calls to typenamep, which shares the definition.")
(\INSTANCEP.UFN OBJECT (\ATOMPNAMEINDEX TYPE))))
(\TYPECHECK.UFN
[LAMBDA (OBJ TYPEN) (* gbn "23-Sep-86 20:06")
(* ufn for TYPECHECK opcode -
cause error if not of right type)
(PROG ((N (NTYPX OBJ)))
LP (COND
((EQ (fetch DTDNAME of (\GETDTD N))
TYPEN)
(RETURN OBJ))
([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N]
(GO LP))
(T (RETURN (\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN))
T])
(GETDESCRIPTORS
[LAMBDA (TYPENAME) (* lmm "21-Apr-85 15:10")
(PROG NIL
(RETURN (fetch DTDDESCRS of (\GETDTD (COND
((LITATOM TYPENAME)
(OR (\TYPENUMBERFROMNAME TYPENAME)
(RETURN)))
(T (NTYPX TYPENAME])
(GETSUPERTYPE
[LAMBDA (TYPENAME) (* lmm "13-Mar-86 14:36")
(* return the name of the supertype
(i.e., the :INCLUDEd type) of a
datatype if it has one, NIL otherwise)
(LET ((NX (\TYPENUMBERFROMNAME TYPENAME)))
(COND
(NX (LET [(N (fetch DTDSUPERTYPE of (\GETDTD NX]
(COND
((NEQ N 0)
(\TYPENAMEFROMNUMBER N))
(T NIL])
(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 65280 (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])
(TYPENAMEP
(LAMBDA (DATUM TYPE) (* gbn "26-Sep-86 17:10")
(\INSTANCEP.UFN DATUM (\ATOMPNAMEINDEX TYPE))))
(\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 (COND
((EQ 0 TYPENO)
(type? ARRAYBLOCK X))
(T (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)
NIL T)
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD)
NIL T)
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL)
NIL T)
(DECLARE:
(* FOLLOWING DEFINITIONS EXPORTED)
(DEFOPTIMIZER TYPENAMEP (&BODY BODY) (COND
((AND (EQ (CAADR BODY)
(QUOTE QUOTE))
(SYMBOLP (CADR (CADR BODY))))
(BQUOTE ((OPCODES INSTANCEP 0 (ATOM \, (CADR (CADR BODY))))
(\, (CAR BODY)))))
(T (QUOTE IGNOREMACRO))))
(DEFOPTIMIZER \INSTANCE-P (&BODY BODY) (COND
((AND (EQ (CAADR BODY)
(QUOTE QUOTE))
(SYMBOLP (CADR (CADR BODY))))
(BQUOTE ((OPCODES INSTANCEP 0 (ATOM \, (CADR (CADR BODY)))
)
(\, (CAR BODY)))))
(T (QUOTE IGNOREMACRO))))
(* END EXPORTED DEFINITIONS)
)
(* ; "STORAGE")
(DEFINEQ
(STORAGE
[LAMBDA (TYPES PAGETHRESHOLD) (* bvm: "13-Jun-86 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))
(SETQ DOBLOCKSFLG T)))
(COND
(DOBLOCKSFLG (\SHOW.ARRAY.FREELISTS])
(STORAGE.LEFT
[LAMBDA NIL (* bvm: "24-Apr-85 15:02")
(* * Return a list MDS+Arrays left in 8mb, in 24mb, litatoms left, pnames left
and the same as fractions)
(PROG ((MDSFREE (IPLUS (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)
\PagesPerMDSUnit
(SELECTC \STORAGEFULLSTATE
(\SFS.SWITCHABLE (* We have another 24MB to work with)
(IPLUS (IDIFFERENCE \SecondMDSPage \SecondArrayPage)
\PagesPerMDSUnit))
(\SFS.ARRAYSWITCHED (* Account for the space left behind
after array allocation moved)
(IPLUS (IDIFFERENCE \NxtMDSPage \LeastMDSPage)
\PagesPerMDSUnit))
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 \PagesPerMDSUnit)
\FirstArrayPage)
(COND
((EQ \STORAGEFULLSTATE \SFS.NOTSWITCHABLE)
0)
(T (IDIFFERENCE (IPLUS \SecondMDSPage
\PagesPerMDSUnit)
\SecondArrayPage]
(RETURN (LIST MDSFREE MDSFRAC (SELECTC \STORAGEFULLSTATE
(\SFS.NOTSWITCHABLE
MDSFRAC)
(\SFS.SWITCHABLE
(FQUOTIENT (IDIFFERENCE (IPLUS \NxtMDSPage
\PagesPerMDSUnit)
\NxtArrayPage)
(IDIFFERENCE (IPLUS \FirstMDSPage
\PagesPerMDSUnit)
\FirstArrayPage)))
0)
(SETQ ATOMSLEFT (IDIFFERENCE ATOMTOTAL (ITIMES (FOLDHI \AtomFrLst
CELLSPERPAGE)
4)))
(FQUOTIENT ATOMSLEFT ATOMTOTAL])
(\STORAGE.TYPE
[LAMBDA (TYPE FREE TOTALALLOCMDS PAGETHRESHOLD) (* bvm: "13-Jun-86 17:22")
(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])
(COND
((EQ SIZE 0)
(RETURN))
(T (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
((ILESSP NPAGESALLOCATED (OR PAGETHRESHOLD 1))
(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))
(\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)
(DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (DATUM OFFSET NEWVALUE)
(UNINTERRUPTABLY
(\PUTBASEBYTE DATUM
(ADD1 (LLSH OFFSET 1))
(LOGAND (\HILOC NEWVALUE)
255))
(\PUTBASE DATUM (ADD1 OFFSET)
(\LOLOC NEWVALUE))
NEWVALUE)))
ARGS))
(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)
)
(RPAQQ \BUILT-IN-SYSTEM-TYPES ((SMALLP)
(FIXP 2)
(FLOATP 2)
(LITATOM)
(LISTP 4 0 2)
(ARRAYP 4 0)
(STRINGP 4 0)
(STACKP 2)
(CHARACTER)
(VMEMPAGEP 256)
(STREAM)
(BITMAP)
(COMPILED-CLOSURE 4 0 2)
(ONED-ARRAY)
(TWOD-ARRAY)
(GENERAL-ARRAY)))
(* END EXPORTED DEFINITIONS)
DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD DTD ((DTDNAME WORD) (* "Type name -- a symbol")
(DTDSIZE WORD) (* "Length of datum in words")
(DTDFREE FULLXPOINTER) (*
"Pointer to first object on free chain, or NIL. Not used for LISTP")
(NIL BITS 2)
(DTDOBSOLETE FLAG) (*
"True for type of a redeclared datatype--not allowed to allocate more of these")
(DTDFINALIZABLE FLAG) (*
"True if finalization exists for this type")
(DTDLOCKEDP FLAG) (*
"True if objects of this type must be locked down (not pagefault)")
(DTDHUNKP FLAG) (*
"True if this type is used as an array hunk type")
(DTDGCTYPE BITS 2) (*
"For hunk datatypes, is analogous to arrayblock's GCTYPE")
(DTDDESCRS POINTER)
(DTDTYPESPECS POINTER)
(DTDPTRS POINTER) (*
"List of word offsets inside datum where reference-counted pointers are stored -- used by GC")
(DTDOLDCNT FIXP) (*
"'Box count' -- number of objects of this type ever allocated")
(DTDCNT0 WORD) (*
"Incremental box count -- this plus DTDOLDCNT is the true box count")
(DTDNEXTPAGE WORD) (*
"Currently only for LISTP pages -- page number of next page on chain of non-full cons pages")
(DTDTYPEENTRY WORD) (* "The word stored in the type table for objects of this type. Hi bits have numberp tags, ref countable, etc.")
(DTDSUPERTYPE WORD) (*
"Type number of immediate supertype, or zero if none")
)
(ACCESSFNS DTD ((DTDCNTLOC (\ADDBASE DATUM 10))
(DTDCNT (IPLUS (fetch DTDOLDCNT DATUM)
(fetch DTDCNT0 DATUM))
(UNINTERRUPTABLY
(replace DTDOLDCNT of DATUM with NEWVALUE)
(replace DTDCNT0 of DATUM with 0))))))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETDTD MACRO ((typeNum)
(ADDBASE \DTDSpaceBase (LLSH typeNum 4))))
(PUTPROPS \TYPEMASK.UFN DMACRO (X (LET ((CE (CONSTANTEXPRESSIONP (CADR X))))
(if CE then (BQUOTE ((OPCODES TYPEMASK.N , (CAR CE))
,
(CAR X)))
else
(QUOTE IGNOREMACRO)))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \GUARDSTORAGEFULL 128)
(RPAQQ \GUARD1STORAGEFULL 64)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage \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)
(CHARACTER)
(VMEMPAGEP 256)
(STREAM)
(BITMAP)
(COMPILED-CLOSURE 4 0 2)
(ONED-ARRAY)
(TWOD-ARRAY)
(GENERAL-ARRAY)))
)
(* ; "for MAKEINIT")
(DEFINEQ
(CREATEMDSTYPETABLE
[LAMBDA NIL (* lmm "10-Jul-85 14:36")
(* 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 \TT.FIXP \TT.NUMBERP \TT.ATOM \SMALLP]
(for PAGE from 0 to (SUB1 PAGESPERSEGMENT) by (FOLDLO \MDSIncrement WORDSPERPAGE)
do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD \CHARHI PAGESPERSEGMENT))
(LOGOR \TT.NOREF \CHARACTERP]
(CREATEPAGES \MISCSTATS (FOLDLO \MDSIncrement WORDSPERPAGE)
NIL T)
(\MAKEMDSENTRY (PAGELOC \MISCSTATS)
(LOGOR \TT.NOREF \TT.FIXP \TT.NUMBERP \TT.ATOM \FIXP])
(INITDATATYPES
[LAMBDA NIL (* bvm: "26-Sep-86 13:47")
(* ;;; "Called only under MAKEINIT. Create the initial data type table from the info in the list INITIALDTDCONTENTS, whose elements are in type number order and of the form (name size . pointer-fields). Called before it is possible to make new atoms, so the DTDNAME field will not be filled in until INITDATATYPENAMES runs. We have to run this before turning on atoms so that we can create strings and pnames.")
(LET [(NSYSTYPES (ALLOCAL (LENGTH INITIALDTDCONTENTS]
(CREATEPAGES \DTDSpaceBase 1 NIL T) (* ;; "First DTD page is locked, probably because CONS microcode touches the listp dtd. Not sure this is essential")
(CREATEPAGES (\ADDBASE \DTDSpaceBase WORDSPERPAGE)
(SUB1 (FOLDHI (TIMES (ADD1 NSYSTYPES)
\DTDSize)
WORDSPERPAGE))) (* ;; "Create the rest of the pages we will need for initial dtd. They need not be locked. (ADD1 NSYSTYPES) is because nonexistent type zero occupies table space")
(for D in (LOCAL INITIALDTDCONTENTS) bind DTD as TYPENO from 1
do (* ;; "Run thru the initial data type decls (the gut-level system datatypes), and declare them in the INIT.DLINIT.")
(SETQ DTD (\GETDTD TYPENO)) (* ;
"Create a Data-Type-Descriptor for the new type")
[replace DTDTYPEENTRY of DTD
with (LOGOR TYPENO (COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP FLOATP]
\TT.NUMBERP)
(T 0))
(COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP FLOATP LITATOM]
\TT.ATOM)
(T 0))
(COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP]
\TT.FIXP)
(T 0))
(COND
((ALLOCAL (NOT (CADR D))) (* "no size, no ref. For those types that are really declared later on, \ASSIGNDATATYPE1 will fix DTDTYPEENTRY to be correct")
\TT.NOREF)
(T 0] (* ;
"Set up the type-mask field with the appropriate meta-type bits")
[COND
((ALLOCAL (AND (CAR D)
(CADR D))) (* "Set the data type's size")
(replace DTDSIZE of DTD with (LOCAL (CADR D]
(if (FMEMB (CAR D)
(QUOTE (STACKP VMEMPAGEP)))
then (* ;
"these types require special action from reclaim")
(replace DTDFINALIZABLE of DTD with T)))
[COND
((NEQ CDRCODING 0)
(SETQ.NOREF \LISTPDTD (\GETDTD \LISTP]
(SETQ \MaxSysTypeNum (SETQ \MaxTypeNumber NSYSTYPES))
NIL])
(INITDATATYPENAMES
[LAMBDA NIL (* bvm: "14-Jun-86 15:35")
(* * "Called in MAKEINIT after it is ok to create new atoms to finish initializing the data type tables -- fill in type names and the list of pointers")
(for D in (LOCAL INITIALDTDCONTENTS) as NTYPX from 1
do (LET ((DTD (\GETDTD NTYPX)))
[replace DTDNAME of DTD with (\ATOMPNAMEINDEX (LOCAL (CAR D]
(*
"Smash the name from our world into his")
[replace DTDPTRS of DTD with (COPY (LOCAL (CDDR D]
(* "And the list of pointer offsets")
])
)
(DECLARE: DONTCOPY
(ADDTOVAR INITVALUES (\NxtMDSPage \FirstMDSPage)
(\LeastMDSPage \FirstMDSPage)
(\SecondMDSPage \DefaultSecondMDSPage)
(\SecondArrayPage \DefaultSecondArrayPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(ADDTOVAR INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \INITMDSPAGE \ASSIGNDATATYPE1
\TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS \BUILT-IN-SYSTEM-TYPES))
(ADDTOVAR RDCOMS (FNS NTYPX TYPENAME \TYPENAMEFROMNUMBER))
(ADDTOVAR RDVALS (\MaxTypeNumber))
(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)
)
(PUTPROPS LLDATATYPE FILETYPE COMPILE-FILE)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
DTDECLARE)
)
(PUTPROPS LLDATATYPE COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5173 36654 (NTYPX 5183 . 5680) (\TYPEMASK.UFN 5682 . 6144) (\TYPEP.UFN 6146 . 6319) (
\ALLOCMDSPAGE 6321 . 7512) (\ALLOCPAGEBLOCK 7514 . 8350) (\ALLOCVIRTUALPAGEBLOCK 8352 . 11256) (
\MAPMDS 11258 . 13337) (\CHECKFORSTORAGEFULL 13339 . 18660) (\DOSTORAGEFULLINTERRUPT 18662 . 18990) (
\SET.STORAGE.STATE 18992 . 19880) (\SETTYPEMASK 19882 . 20547) (\ADVANCE.STORAGE.STATE 20549 . 21141)
(\NEW2PAGE 21143 . 21332) (\MAKEMDSENTRY 21334 . 21591) (\INITMDSPAGE 21593 . 23631) (\ASSIGNDATATYPE1
23633 . 32740) (\RESOLVE.TYPENUMBER 32742 . 33232) (\ASSIGN.DATATYPE 33234 . 33849) (
\TYPENUMBERFROMNAME 33851 . 34215) (CREATECELL 34217 . 34354) (\CREATECELL 34356 . 36652)) (37023
58342 (FETCHFIELD 37033 . 40343) (REPLACEFIELD 40345 . 45994) (BOXCOUNT 45996 . 46504) (CONSCOUNT
46506 . 46644) (\DTEST 46646 . 46800) (\TYPECHECK 46802 . 46960) (\DTEST.UFN 46962 . 50319) (
\INSTANCEP.UFN 50321 . 50921) (\INSTANCE-P 50923 . 51263) (\TYPECHECK.UFN 51265 . 51945) (
GETDESCRIPTORS 51947 . 52441) (GETSUPERTYPE 52443 . 53146) (GETFIELDSPECS 53148 . 53687) (NCREATE
53689 . 53865) (NCREATE2 53867 . 54608) (REPLACEFIELDVAL 54610 . 54992) (PUTBASEPTRX 54994 . 55347) (
/REPLACEFIELD 55349 . 55659) (TYPENAME 55661 . 55965) (TYPENAMEP 55967 . 56132) (\TYPENAMEFROMNUMBER
56134 . 56368) (\BLOCKDATAP 56370 . 56694) (USERDATATYPES 56696 . 56832) (DATATYPEP 56834 . 58022) (
DATATYPES 58024 . 58340)) (59714 73376 (STORAGE 59724 . 64014) (STORAGE.LEFT 64016 . 67997) (
\STORAGE.TYPE 67999 . 71741) (\STLINP 71743 . 71932) (\STMDSTYPE 71934 . 72147) (\STORAGE.HUNKTYPE
72149 . 73374)) (80605 86737 (CREATEMDSTYPETABLE 80615 . 82133) (INITDATATYPES 82135 . 85857) (
INITDATATYPENAMES 85859 . 86735)))))
STOP