(FILECREATED "14-AUG-83 17:15:51" {PHYLUM}<LISPCORE>SOURCES>LLDATATYPE.;43 27694
changes to: (FNS STORAGE)
previous date: "13-AUG-83 01:39:28" {PHYLUM}<LISPCORE>SOURCES>LLDATATYPE.;42)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT LLDATATYPECOMS)
(RPAQQ LLDATATYPECOMS ((* general datatypes)
(FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE ASSIGNDATATYPE
\TYPENUMBERFROMNAME CREATECELL \CREATECELL)
(INITVARS (CROSSCOMPILING))
(GLOBALVARS CROSSCOMPILING)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(INITVARS (\STORAGEFULL))
(DECLARE: DONTCOPY (EXPORT (MACROS PUTBASEPTRX)
(RECORDS DTD)
(MACROS \GETDTD))
(VARS DTDECLS)
(GLOBALVARS \NxtMDSPage \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE
\PENDINGINTERRUPT)
(ADDVARS (INITVALUES (\NxtMDSPage 256)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE
ASSIGNDATATYPE \TYPENUMBERFROMNAME \CREATECELL)
(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)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)))
(FNS FETCHFIELD REPLACEFIELD BOXCOUNT CONSCOUNT \DTEST \DTESTFAIL GETDESCRIPTORS
GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL PUTBASEPTRX /REPLACEFIELD STORAGE \STLINP
TYPENAME \TYPENAMEFROMNUMBER USERDATATYPES DATATYPEP DATATYPES)
(P (MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD))
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD))
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL)))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
DTDECLARE))))
(* general datatypes)
(DEFINEQ
(NTYPX
[LAMBDA (X) (* lmm " 2-JAN-82 14:24")
(* usually done in microcode -
this def used by MAKEINIT too)
(LOGAND (\GETBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of X)
1))
\TT.TYPEMASK])
(\ALLOCMDSPAGE
[LAMBDA (TYP) (* lmm "13-AUG-83 01:35")
(DECLARE (GLOBALVARS \INTERRUPTSTATE \PENDINGINTERRUPT))
(PROG ((VP \NxtMDSPage)
VPTR)
[COND
((OR (IGEQ VP \Guard1MDSPage)
(\GCDISABLED)) (* possibly at the "storage full" boundary.)
(COND
((EQ VP (FLOOR \LastMDSPage 2))
(* FLOOR because VP is always even)
(do (RAID "Fixed Data Space completely full")))
((EQ VP (FLOOR \GuardMDSPage 2))
(* FLOOR because VP is always even)
(RAID
"Space for fixed-length data getting VERY full. Please save and reload a.s.a.p. Type control-N to continue now."
))
((NOT \STORAGEFULL)
(SETQ \STORAGEFULL T)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T]
(SETQ \NxtMDSPage (IPLUS VP 2))
(* Allocates 2 MDS pages)
(\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)
(\NEWPAGE (\ADDBASE (\NEWPAGE (SETQ VPTR (create POINTER
PAGE# ← VP)))
WORDSPERPAGE))
(RETURN VPTR])
(\MAKEMDSENTRY
[LAMBDA (VP V) (* lmm "30-DEC-81 17:39")
(\PUTBASE \MDSTypeTable (LRSH VP 1)
V])
(\GCTYPE
[LAMBDA (TYPENUM DTD) (* bvm: "16-DEC-82 12:17")
(COND
((OR (EQ CDRCODING 0)
(NEQ TYPENUM \LISTP))
(* 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])
(\INITMDSPAGE
[LAMBDA (BASE SIZE PREV) (* lmm "10-DEC-82 16:12")
(* chain free list thru page at BASE of items SIZE long
-
return last element)
(PROG ((DISP 0))
(while (ILEQ (IPLUS DISP SIZE)
\MDSIncrement)
do (\PUTBASEPTR BASE 0 PREV)
(SETQ PREV BASE)
(SETQ BASE (\ADDBASE BASE SIZE))
(SETQ DISP (IPLUS DISP SIZE)))
(RETURN PREV])
(ASSIGNDATATYPE
[LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS GVNAME)
(* lmm "20-MAY-83 09:37")
(PROG (DTD (NTYPX (\TYPENUMBERFROMNAME NAME)))
[COND
(NTYPX (* already allocated)
(SETQ DTD (\GETDTD NTYPX))
(COND
([OR (EQUAL DESCRIPTORS (fetch DTDDESCRS of DTD))
(EQ CROSSCOMPILING T)
(AND CROSSCOMPILING (NEQ (QUOTE Y)
(ASKUSER NIL (QUOTE N)
(LIST "OK TO REDECLARE DATATYPE " NAME]
(* if there would be no change, do nothing)
(RETURN NTYPX)))
(COND
((IGREATERP NTYPX \MaxSysTypeNum)
(UNINTERRUPTABLY
(replace DTDNAME of DTD with (\ATOMPNAMEINDEX (QUOTE **DEALLOC**)))
(replace DTDDESCRS of DTD with NIL)
(replace DTDTYPESPECS of DTD with NIL)))
((AND (EQ SIZE (fetch DTDSIZE of DTD))
(EQUAL PTRFIELDS (fetch DTDPTRS of DTD)))
(RETURN NTYPX))
(T (* can't mess with sys types)
(ERROR "ILLEGAL DATA TYPE" NAME]
(COND
((EQ \MaxTypeNumber \EndTypeNumber)
(LISPERROR "DATA TYPES FULL" NAME)))
(UNINTERRUPTABLY
(SETQ NTYPX (add \MaxTypeNumber 1))
(SETQ DTD (\GETDTD NTYPX))
(COND
((IGREATERP \DTDSize (LOGAND (IPLUS (LOLOC DTD)
\DTDSize)
255))
(* yuck)
(* 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])
(\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) (* bvm: "16-DEC-82 16:04")
(PROG (NEWCELL (DTD (\GETDTD TYP)))
(UNINTERRUPTABLY
(SETQ NEWCELL (OR (fetch DTDFREE of DTD)
(\GCTYPE TYP DTD)))
[COND
((AND (NEQ CDRCODING 0)
(EQ TYP \LISTP))
(RAID "CREATECELL \LISTP"))
(T (CHECK (EQ (NTYPX NEWCELL)
TYP]
[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]
(\StatsAdd1 (fetch DTDCNTLOC of DTD))
[PROG ((PTR NEWCELL))
(FRPTQ (FOLDLO (fetch DTDSIZE of DTD)
WORDSPERCELL)
(\PUTBASEPTR PTR 0 NIL)
(SETQ PTR (\ADDBASE PTR WORDSPERCELL]
(* Clear object)
(\CREATEREF NEWCELL))
(RETURN NEWCELL])
)
(RPAQ? CROSSCOMPILING )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS CROSSCOMPILING)
)
(DEFINEQ
(CREATEMDSTYPETABLE
[LAMBDA NIL (* lmm " 2-JAN-82 17:27")
(* 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)
(SETQ VP (PAGELOC \SMALLPOSPSPACE))
(FRPTQ \NumSmallPages (\MAKEMDSENTRY VP (LOGOR \TT.NOREF \SMALLP))
(add VP 1))
(SETQ VP (PAGELOC \ARRAYSPACE))
(FRPTQ \LastArrayPage (\MAKEMDSENTRY VP 0)
(add VP 1])
(INITDATATYPES
[LAMBDA NIL (* lmm "24-DEC-81 01:36")
(* called only under MAKEINIT; called before it is possible to make new atoms)
(CREATEPAGES \STATSSPACE \STATSsize NIL T)
(* probably shouldn't be done here!)
(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 "12-DEC-81 14:51")
(* 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)
(ASSIGNDATATYPE (LOCAL (CAR D))
NIL
(OR (LOCAL (CADR D))
0)
NIL
(COPY (LOCAL (CDDR D]
(SETQ \MaxSysTypeNum \MaxTypeNumber])
)
(RPAQ? \STORAGEFULL )
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS PUTBASEPTRX MACRO (OPENLAMBDA (DATUM OFFSET NEWVALUE)
(UNINTERRUPTABLY
(\PUTBASE DATUM OFFSET (LOGOR (LOGAND 65280
(\GETBASE DATUM
OFFSET))
(\HILOC NEWVALUE)))
(\PUTBASE DATUM (ADD1 OFFSET)
(LOLOC NEWVALUE))
NEWVALUE)))
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD DTD ((DTDNAME WORD)
(DTDSIZE WORD)
(DTDFREE FULLXPOINTER)
(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))))
)
(* END EXPORTED DEFINITIONS)
(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)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \NxtMDSPage \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE
\PENDINGINTERRUPT)
)
(ADDTOVAR INITVALUES (\NxtMDSPage 256)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(ADDTOVAR INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE ASSIGNDATATYPE
\TYPENUMBERFROMNAME \CREATECELL)
(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))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
)
(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) (* edited: " 7-JUN-83 10:22")
(* 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 (PutFloat (\ADDBASE 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 177777Q
(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 177777Q (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 177777Q
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND (COND
(NEWVALUE 177777Q)
(T 0))
MASK)
SHIFT)))
(AND NEWVALUE T))
(LONGBITS (PROG (LO HI)
(.UNBOX. NEWVALUE LO HI)
(UNINTERRUPTABLY
(\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 177777Q
(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 " 2-JUL-83 12:12")
(* ufn for DTEST opcode)
(COND
((EQ (fetch DTDNAME of (\GETDTD (NTYPX OBJ)))
TYPEN) (* should not happen)
OBJ)
(T (SELECTQ (\INDEXATOMPNAME TYPEN)
[DISPLAYSTREAM (COND
((type? WINDOW OBJ)
(fetch (WINDOW DSP) of OBJ))
[(NULL OBJ)
(PROG (DS)
(RETURN (COND
([DISPLAYSTREAMP (SETQ DS
(fetch (STREAMOFDISPLAYSTREAM
DISPLAYSTREAM)
of (\GETOFD NIL
(QUOTE OUTPUT]
DS)
(T (\ILLEGAL.ARG OBJ]
(T (\ILLEGAL.ARG OBJ]
(FONTDESCRIPTOR (\COERCEFONTDESC OBJ))
(STREAM (\GETOFD OBJ (SELECTQ (STKNTHNAME -1 (QUOTE \DTESTFAIL))
((BINS \BIN BIN)
(QUOTE INPUT))
((BOUTS \BOUT BOUT)
(QUOTE OUTPUT))
NIL)))
(LISTP (LISPERROR "ARG NOT LIST" OBJ T))
[SMALLP (PROG (HI LO)
(.UNBOX. OBJ HI LO)
(RETURN (OR (SMALLP (\MAKENUMBER HI LO))
(LISPERROR "ILLEGAL ARG" 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))
(HARRAYP (LISPERROR "ARG NOT HARRAY" OBJ T))
(\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) (* lmm " 9-DEC-81 11:17")
(* 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
(\MOVEBLOCK 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])
(STORAGE
[LAMBDA NIL (* lmm "14-AUG-83 17:14")
(PROG ((TOTALALLOCMDS (CREATECELL \FIXP))
(TOTALUSED (CREATECELL \FIXP))
(FREE (CREATECELL \FIXP))
(MDSPERPAGE (IQUOTIENT \MDSIncrement WORDSPERPAGE)))
(printout NIL "Type" 15 "Assigned" 30 "Free items" 45 "In use" 60 "Total allocations" T 15
"pages [items]"
T)
(for I from 1 to \MaxTypeNumber
do (PROG (DTD SIZE NAME ALLOC INUSE ITEMSPERMDS INUSEPAGES ALLOCMDS)
(SETQ DTD (\GETDTD I))
(OR (SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD)))
(RETURN))
(SETQ SIZE (fetch DTDSIZE of DTD))
(CHECK (EVENP SIZE WORDSPERCELL))
(SETQ ITEMSPERMDS (SELECTQ NAME
((LITATOM SMALLP)
(RETURN))
[LISTP (COND
((ZEROP CDRCODING)
(IQUOTIENT \MDSIncrement SIZE))
(T (CONSTANT (FIX (FQUOTIENT \MDSIncrement
2.2]
(IQUOTIENT \MDSIncrement SIZE)))
(\StatsZero FREE)
[COND
[(AND (NEQ CDRCODING 0)
(EQ I \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)
I)
(EVENP (IMOD (\LOLOC PTR)
\MDSIncrement)
SIZE))
(\BOXIPLUS FREE 1]
(SETQ ALLOCMDS (for J from 0 to (SUB1 \NxtMDSPage) by MDSPERPAGE
when (EQ I (NTYPX (create POINTER
PAGE# ← J)))
sum 1))
(\BOXIPLUS TOTALALLOCMDS ALLOCMDS)
(SETQ INUSE (IDIFFERENCE (SETQ ALLOC (ITIMES ALLOCMDS ITEMSPERMDS))
FREE))
(printout NIL NAME 15 .I5 (ITIMES ALLOCMDS MDSPERPAGE)
.I8 ALLOC 30 .I8 FREE 45 .I8 INUSE 60 .I10 (BOXCOUNT I)
T)))
(printout NIL T "TOTAL" 15 .I5 (ITIMES TOTALALLOCMDS MDSPERPAGE)
T T)
(printout NIL "Data Spaces" T)
(printout NIL 10 "Allocated" 21 "Remaining" T)
(printout NIL 12 "Pages" 23 "Pages" T)
(\STLINP "MDS" (IDIFFERENCE (IDIFFERENCE \NxtMDSPage 2)
\FirstMDSPage)
\LastMDSPage)
(\STLINP "Atoms" (ADD1 (LRSH \AtomFrLst 8))
\LastAtomPage)
(\STLINP "Print Names" (ADD1 \CurPnPage)
\LastPnPage)
(\STLINP "Arrays" (IDIFFERENCE \NxtArrayPage (LLSH \ARRAYspace 8))
\LastArrayPage])
(\STLINP
[LAMBDA (N A TOT) (* lmm "14-MAY-80 08:37")
(printout NIL N 12 A 23 (ADD1 (IDIFFERENCE TOT A))
T])
(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])
(USERDATATYPES
[LAMBDA NIL (* rrb "16-JUL-80 13:17")
(DATATYPES T])
(DATATYPEP
[LAMBDA (DATATYPESPEC) (* lmm "13-FEB-83 14:14")
(* returns the type name of a data type spec if it is a datatype.)
(COND
[(NUMBERP DATATYPESPEC)
(PROG (NAME)
(RETURN (AND [SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD DATATYPESPEC]
(NEQ NAME (QUOTE **DEALLOC**))
NAME]
((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))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
DTDECLARE)
)
(PUTPROPS LLDATATYPE COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2227 8904 (NTYPX 2237 . 2534) (\ALLOCMDSPAGE 2536 . 3969) (\MAKEMDSENTRY 3971 . 4105) (
\GCTYPE 4107 . 4684) (\INITMDSPAGE 4686 . 5212) (ASSIGNDATATYPE 5214 . 7300) (\TYPENUMBERFROMNAME 7302
. 7601) (CREATECELL 7603 . 7736) (\CREATECELL 7738 . 8902)) (9008 11240 (CREATEMDSTYPETABLE 9018 .
9769) (INITDATATYPES 9771 . 10531) (INITDATATYPENAMES 10533 . 11238)) (13546 27293 (FETCHFIELD 13556
. 15425) (REPLACEFIELD 15427 . 18410) (BOXCOUNT 18412 . 18755) (CONSCOUNT 18757 . 18863) (\DTEST
18865 . 18989) (\DTESTFAIL 18991 . 20535) (GETDESCRIPTORS 20537 . 20873) (GETFIELDSPECS 20875 . 21204)
(NCREATE 21206 . 21342) (NCREATE2 21344 . 21977) (REPLACEFIELDVAL 21979 . 22276) (PUTBASEPTRX 22278
. 22589) (/REPLACEFIELD 22591 . 22879) (STORAGE 22881 . 25633) (\STLINP 25635 . 25780) (TYPENAME
25782 . 26024) (\TYPENAMEFROMNUMBER 26026 . 26222) (USERDATATYPES 26224 . 26328) (DATATYPEP 26330 .
27042) (DATATYPES 27044 . 27291)))))
STOP