(FILECREATED "22-Dec-83 00:06:24" {PHYLUM}<LISPCORE>ARRAYS>LLDATATYPE.;1 30597
changes to: (FNS \DTESTFAIL)
previous date: " 8-Dec-83 16:49:24" {PHYLUM}<LISPCORE>SOURCES>LLDATATYPE.;53)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT LLDATATYPECOMS)
(RPAQQ LLDATATYPECOMS ((* general datatypes)
(FNS NTYPX \ALLOCMDSPAGE \MAPMDS \CHECKFORSTORAGEFULL \NEW2PAGE \MAKEMDSENTRY \GCTYPE
\INITMDSPAGE ASSIGNDATATYPE \TYPENUMBERFROMNAME CREATECELL \CREATECELL)
(INITVARS (CROSSCOMPILING)
(ASSIGNDATATYPE.ASKUSERWAIT))
(GLOBALVARS CROSSCOMPILING)
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(INITVARS (\STORAGEFULL))
(DECLARE: (EXPORT (MACROS PUTBASEPTRX))
DONTCOPY
(EXPORT (RECORDS DTD)
(MACROS \GETDTD)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL))
(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 \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)))
(FNS FETCHFIELD REPLACEFIELD BOXCOUNT CONSCOUNT \DTEST \DTESTFAIL GETDESCRIPTORS
GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL PUTBASEPTRX /REPLACEFIELD STORAGE
\STORAGE.TYPE \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 " 8-SEP-83 06:50")
(DECLARE (GLOBALVARS \INTERRUPTSTATE \PENDINGINTERRUPT))
(PROG ((VP \NxtMDSPage)
VPTR)
(COND
((ILEQ VP \LastMDSPage)
(SETQ \NxtMDSPage (IPLUS VP 2)))
(T [SETQ \LASTARRAYPAGE (SUB1 (SETQ VP (SUB1 \LASTARRAYPAGE]
(\CHECKFORSTORAGEFULL)))
(* 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])
(\MAPMDS
[LAMBDA (TYPE FN) (* rrb " 8-SEP-83 15:15")
[AND TYPE (OR (FIXP TYPE)
(SETQ TYPE (\TYPENUMBERFROMNAME TYPE]
(PROG (PTR VP TYP (NXT \FirstMDSPage)
(LAP \ENDARRAYPAGE))
LP (SETQ VP NXT)
[COND
((ILEQ VP \LastMDSPage)
(COND
((IGEQ VP \NxtMDSPage)
(RETURN)))
(SETQ NXT (IPLUS VP 2)))
(T [SETQ LAP (SUB1 (SETQ NXT (SETQ VP (SUB1 LAP]
(COND
((ILESSP VP \NxtMDSPage)
(RETURN]
(SETQ PTR (create POINTER
PAGE# ← VP))
[SELECTC (SETQ TYP (NTYPX PTR))
((LIST 0 \SMALLP) (* reached end of allocated pages or smallposp pages)
NIL)
(COND
((OR (NULL TYPE)
(EQ TYP TYPE))
(SPREADAPPLY* FN (fetch (POINTER PAGE#) of PTR]
(GO LP])
(\CHECKFORSTORAGEFULL
[LAMBDA NIL (* lmm " 3-SEP-83 23:37")
(COND
((IGREATERP \NxtArrayPage \LASTARRAYPAGE)
(do (RAID "Storage completely full")))
((ILESSP (IDIFFERENCE \LASTARRAYPAGE \NxtArrayPage)
\GUARDSTORAGEFULL)
[COND
((EQ (FLOOR (IDIFFERENCE \LASTARRAYPAGE \NxtArrayPage)
2)
\GUARD1STORAGEFULL)
(RAID
"Space getting VERY full. Please save and reload a.s.a.p. Type control-N to continue now."))
((NOT \STORAGEFULL)
(UNINTERRUPTABLY
(SETQ \STORAGEFULL T)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T))]
(\DORECLAIM])
(\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) (* 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) (* bvm: "13-NOV-83 16:09")
(PROG ((NTYPX (\TYPENUMBERFROMNAME NAME))
DTD)
[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 ASSIGNDATATYPE.ASKUSERWAIT (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 (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])
(\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 )
(RPAQ? ASSIGNDATATYPE.ASKUSERWAIT )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS CROSSCOMPILING)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT)
)
(DEFINEQ
(CREATEMDSTYPETABLE
[LAMBDA NIL (* lmm " 3-SEP-83 22:32")
(* 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 2
do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD SEGMENT PAGESPERSEGMENT))
(LOGOR \TT.NOREF \SMALLP]
(SETQ VP (PAGELOC \ARRAYSPACE))
(while (ILEQ VP \ENDARRAYPAGE)
do (\MAKEMDSENTRY VP 0)
(add VP 2])
(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:
(* 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)
DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[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))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \GUARDSTORAGEFULL 128)
(RPAQQ \GUARD1STORAGEFULL 64)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
)
(* 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 \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)
)
(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) (* rmk: "21-Dec-83 15:08")
(* ufn for DTEST opcode)
(COND
((EQ (fetch DTDNAME of (\GETDTD (NTYPX OBJ)))
TYPEN) (* should not happen)
OBJ)
(T (SELECTQ (\INDEXATOMPNAME TYPEN)
(FONTDESCRIPTOR (\COERCEFONTDESC 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]
[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) (* 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 (TYPES PAGETHRESHOLD) (* bvm: " 5-Dec-83 19:29")
(PROG ((TOTALALLOCMDS (CREATECELL \FIXP))
(FREE (CREATECELL \FIXP)))
(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 inside TYPES when (OR (FIXP TYPE)
(SETQ TYPE (\TYPENUMBERFROMNAME TYPE)))
do (\STORAGE.TYPE TYPE FREE TOTALALLOCMDS PAGETHRESHOLD)))
(T (for I from 1 to \MaxTypeNumber do (\STORAGE.TYPE I FREE TOTALALLOCMDS PAGETHRESHOLD))
(printout NIL T "TOTAL" 15 .I5 TOTALALLOCMDS T T)
(printout NIL "Data Spaces" T)
(printout NIL 30 "Allocated" 50 "Remaining" T)
(printout NIL 32 "Pages" 52 "Pages" T)
(\STLINP "Fixed-datum space" (IPLUS 2 (IDIFFERENCE \NxtMDSPage \FirstMDSPage))
\LastMDSPage)
(\STLINP "Atoms" (ITIMES (ADD1 (LRSH \AtomFrLst 8))
7)
(IPLUS (ITIMES \LastAtomPage 7)
6))
(\STLINP "Print Names" (ADD1 \CurPnPage)
\LastPnPage)
(\STLINP "variable-datum space" (IPLUS (IDIFFERENCE \NxtArrayPage (LLSH \ARRAYspace 8))
(IDIFFERENCE \ENDARRAYPAGE \LASTARRAYPAGE))
\NUMARRAYPAGES])
(\STORAGE.TYPE
[LAMBDA (TYPE FREE TOTALALLOCMDS PAGETHRESHOLD) (* bvm: " 5-Dec-83 19:29")
(PROG (DTD SIZE NAME ALLOC INUSE ITEMSPERMDS INUSEPAGES NPAGESALLOCATED (ALLOCMDS 0))
(DECLARE (SPECVARS ALLOCMDS))
(SETQ DTD (\GETDTD TYPE))
(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)
[\MAPMDS TYPE (FUNCTION (LAMBDA NIL
(add ALLOCMDS 1]
(SETQ NPAGESALLOCATED (ITIMES ALLOCMDS (IQUOTIENT \MDSIncrement WORDSPERPAGE)))
(COND
((AND PAGETHRESHOLD (ILESSP NPAGESALLOCATED PAGETHRESHOLD))
(RETURN)))
(\BOXIPLUS TOTALALLOCMDS NPAGESALLOCATED)
[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))
(printout NIL (SELECTQ NAME
(LISTP "LISTP ~")
NAME)
15 .I5 NPAGESALLOCATED .I8 ALLOC 30 .I8 FREE 43 .I8 INUSE 56 .I10 (BOXCOUNT
TYPE)
T])
(\STLINP
[LAMBDA (STR ALLOC TOT) (* lmm " 8-SEP-83 06:46")
(printout NIL STR 30 .I8 ALLOC 50 .I8 (ADD1 (IDIFFERENCE TOT ALLOC))
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 (2466 10434 (NTYPX 2476 . 2773) (\ALLOCMDSPAGE 2775 . 3671) (\MAPMDS 3673 . 4549) (
\CHECKFORSTORAGEFULL 4551 . 5235) (\NEW2PAGE 5237 . 5404) (\MAKEMDSENTRY 5406 . 5540) (\GCTYPE 5542 .
6119) (\INITMDSPAGE 6121 . 6647) (ASSIGNDATATYPE 6649 . 8830) (\TYPENUMBERFROMNAME 8832 . 9131) (
CREATECELL 9133 . 9266) (\CREATECELL 9268 . 10432)) (10654 13019 (CREATEMDSTYPETABLE 10664 . 11548) (
INITDATATYPES 11550 . 12310) (INITDATATYPENAMES 12312 . 13017)) (15556 30196 (FETCHFIELD 15566 . 17435
) (REPLACEFIELD 17437 . 20420) (BOXCOUNT 20422 . 20765) (CONSCOUNT 20767 . 20873) (\DTEST 20875 .
20999) (\DTESTFAIL 21001 . 22845) (GETDESCRIPTORS 22847 . 23183) (GETFIELDSPECS 23185 . 23514) (
NCREATE 23516 . 23652) (NCREATE2 23654 . 24287) (REPLACEFIELDVAL 24289 . 24586) (PUTBASEPTRX 24588 .
24899) (/REPLACEFIELD 24901 . 25189) (STORAGE 25191 . 26551) (\STORAGE.TYPE 26553 . 28516) (\STLINP
28518 . 28683) (TYPENAME 28685 . 28927) (\TYPENAMEFROMNUMBER 28929 . 29125) (USERDATATYPES 29127 .
29231) (DATATYPEP 29233 . 29945) (DATATYPES 29947 . 30194)))))
STOP