(FILECREATED "21-Jan-84 05:21:33" {PHYLUM}<LISPCORE>SOURCES>LLBASIC.;61 41745
changes to: (FNS \BLT)
previous date: "20-Dec-83 16:04:46" {PHYLUM}<LISPCORE>SOURCES>LLBASIC.;60)
(* Copyright (c) 1981, 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LLBASICCOMS)
(RPAQQ LLBASICCOMS [(FNS LISTP LITATOM FIXP STRINGP SMALLP SMALLPOSP NLISTP ARRAYP ATOM FLOATP
NUMBERP STACKP)
[COMS (* ufns)
(FNS INITUFNTABLE \SETUFNENTRY)
(FNS \UNKNOWN.UFN)
(DECLARE: DONTCOPY (RECORDS UFNENTRY)
(ADDVARS (INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS INITUFNTABLE]
(DECLARE: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 SMALLPOSP SETXVAR
SETQ.NOREF IEQ)
(TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF)
(CONSTANTS WordsPerPage)))
[COMS (* atoms)
(FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST
SETPROPLIST)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES)
(FNS MAPATOMS)
(FNS INITATOMS COPYATOM UNCOPYATOM)
(COMS (* \PNAMELIMIT is exported as part of CONSTANT below; this gets it
copied as well. Note that both commands must be editted together)
(VARS (\PNAMELIMIT 255)))
(FNS DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN \SMASHATOM)
(VARS (COMPILEATPUTDFLG))
(DECLARE: DONTCOPY (EXPORT (RECORDS LITATOM VCELL VALINDEX)
(RECORDS DEFINITIONCELL FNHEADER)
(E (* MACROS should go away in favor of record
access))
(MACROS \ATOMVALINDEX \ATOMDEFINDEX
\ATOMPNAMEINDEX \ATOMPROPINDEX
\INDEXATOMPNAME \INDEXATOMVAL
\INDEXATOMDEF)
(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage
\AtomFrLst \OneCharAtomBase
\SCRATCHSTRING COMPILEATPUTDFLG)
(CONSTANTS (\LastAtomPage 127)
(\PNAMELIMIT 255)
(\CharsPerPnPage 512)
(\AtomHTmask 32767)
(\PnCharsFblock 24))
(MACROS GETPROPLIST SETPROPLIST)))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \EQBYTES)
(ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN
PUTDEFN FSETVAL]
(COMS (* for executing boot expressions when first run)
(FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT)
(GLOBALVARS RESETFORMS BOOTFILES))
[COMS (* date/time, stats)
(FNS CLOCK DAYTIME ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE)
(FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER)
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (PROP MACRO ALTO.TO.LISP.DATE
LISP.TO.ALTO.DATE)))
(COMS (* DISMISS is no longer used in system code, when PROCESSWORLD is
running. WAITFORINPUT is called only by ASKUSER and
\WAITFORSYSBUFP is used only in TEDIT)
(FNS DISMISS WAITFORINPUT \WAITFORSYSBUFP)
(GLOBALRESOURCES (\DISMISSBOX (SETUPTIMER 0))
(\DISMISSTIMER (SETUPTIMER 0))
(\DISMISSTIMER-100 (SETUPTIMER 0]
(COMS (* Fast functions for moving and clearing storage)
(FNS \MOVEBYTES \BLT \ZEROWORDS \MOVEWORDS \ZEROBYTES))
(LOCALVARS . T)
(DECLARE: DONTCOPY (* for MAKEINIT and READSYS)
(ADDVARS (INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0))
(INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
[INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES
\MOVEBYTES)
(FNS COPYATOM INITATOMS)
(BLOCKS (\MKATOM \MKATOM NewAtom \MOVEBYTES
(NOLINKFNS . T]
(EXPANDMACROFNS SMALLPOSP \EQBYTES)
(MKI.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 256)
(SETTOPVAL . I.FSETVAL))
(RD.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 256)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(NewAtom . ERROR!))
(RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST
SETTOPVAL GETDEFN \SMASHATOM)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(RDVALS (\AtomFrLst])
(DEFINEQ
(LISTP
[LAMBDA (X) (* lmm "10-MAR-81 15:01")
(* usually done in microcode)
(AND (EQ (NTYPX X)
\LISTP)
X])
(LITATOM
[LAMBDA (X) (* lmm "10-MAR-81 15:05")
(* compiles open to NTYPX check)
(EQ (NTYPX X)
\LITATOM])
(FIXP
[LAMBDA (X) (* lmm "10-MAR-81 15:08")
(* compiles open to TYPEPs)
(SELECTC (NTYPX X)
((LIST \SMALLP \FIXP)
X)
NIL])
(STRINGP
[LAMBDA (X) (* lmm "10-MAR-81 15:09")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\STRINGP X)
NIL])
(SMALLP
[LAMBDA (X) (* lmm "10-MAR-81 15:10")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\SMALLP X)
NIL])
(SMALLPOSP
[LAMBDA (X) (* lmm " 9-NOV-81 21:21")
(EQ (\HILOC X)
\SmallPosHi])
(NLISTP
[LAMBDA (X) (* lmm "10-MAR-81 15:07")
(* compiles open)
(NOT (LISTP X])
(ARRAYP
[LAMBDA (X) (* lmm "10-MAR-81 15:11")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\ARRAYP X)
NIL])
(ATOM
[LAMBDA (X) (* lmm "10-MAR-81 15:08")
(* compiles open)
(SELECTC (NTYPX X)
((LIST \SMALLP \FIXP \FLOATP \LITATOM)
T)
NIL])
(FLOATP
[LAMBDA (X) (* lmm "10-MAR-81 15:11")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\FLOATP X)
NIL])
(NUMBERP
[LAMBDA (X) (* lmm "10-MAR-81 15:12")
(SELECTC (NTYPX X)
((LIST \FIXP \SMALLP \FLOATP)
X)
NIL])
(STACKP
[LAMBDA (X) (* lmm "10-MAR-81 15:13")
(SELECTC (NTYPX X)
(\STACKP X)
NIL])
)
(* ufns)
(DEFINEQ
(INITUFNTABLE
[LAMBDA NIL (* rmk: "11-OCT-83 13:29")
(for I from 0 to 255 do (\SETUFNENTRY I (QUOTE \UNKNOWN.UFN)
0 0))
(for X in \OPCODES when (fetch (OPCODE UFNFN) of X)
do (\SETUFNENTRY (fetch (OPCODE OP#) of X)
(fetch (OPCODE UFNFN) of X)
(IDIFFERENCE (IPLUS 1 (COND
((ZEROP (fetch (OPCODE OPNARGS) of X))
0)
(T 1)))
(fetch (OPCODE LEVADJ) of X))
(fetch (OPCODE OPNARGS) of X])
(\SETUFNENTRY
(LAMBDA (INDEX FN NARGS NEXTRA) (* JonL "16-Dec-83 22:51")
(SETQ INDEX (\ADDBASE (\ADDBASE \UFNTable INDEX)
INDEX))
(replace (UFNENTRY FNINDEX) of INDEX with (\ATOMDEFINDEX FN))
(replace (UFNENTRY NEXTRA) of INDEX with NEXTRA)
(replace (UFNENTRY NARGS) of INDEX with NARGS)))
)
(DEFINEQ
(\UNKNOWN.UFN
[LAMBDA NIL (* lmm "27-JUN-80 22:12")
(RAID "Compiler/microcode error: unknown UFN"])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD UFNENTRY ((FNINDEX WORD)
(NEXTRA BYTE)
(NARGS BYTE)))
]
(ADDTOVAR INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS INITUFNTABLE)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS CHECK MACRO (ARGS
(COND
[(AND (BOUNDP (QUOTE CHECK))
CHECK)
(CONS (QUOTE PROGN)
(for I in ARGS collect (LIST (QUOTE OR)
I
(LIST (QUOTE RAID)
(KWOTE (LIST (QUOTE Check-failure:)
I]
(T (CONS COMMENTFLG ARGS)))))
(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
(\PUTBASE N 0 0)
(\PUTBASE N 1 0)))
(PUTPROPS \StatsAdd1 BYTEMACRO (OPENLAMBDA (A)
[PROG NIL
(\PUTBASE A 1 ([LAMBDA (J)
(DECLARE (LOCALVARS . T))
(COND
((EQ J MAX.SMALL.INTEGER)
[\PUTBASE A 0 (COND
((EQ (\GETBASE A 0)
MAX.POS.HINUM)
0)
(T (ADD1 (\GETBASE A 0]
0)
(T (ADD1 J]
(\GETBASE A 1]))
(PUTPROPS SMALLPOSP MACRO ((X)
(EQ (\HILOC X)
(CONSTANT \SmallPosHi))))
(PUTPROPS SETXVAR MACRO (X
[COND
((EQ (CAAR X)
(QUOTE QUOTE))
(LIST (QUOTE SETQ)
(CADAR X)
(CADR X)))
((LITATOM (CAR X))
(LIST (QUOTE SET)
(CAR X)
(CADR X)))
(T (HELP (CONS X (QUOTE (bad SETXVAR form]))
(PUTPROPS SETXVAR DMACRO (X
(OR (AND (EQ (CAAR X)
(QUOTE QUOTE))
(LITATOM (CADAR X)))
(SHOULDNT))
(GLOBALVARS \VALSPACE)
(LIST (QUOTE SETQ.NOREF)
(CADAR X)
(CADR X))))
(PUTPROPS SETQ.NOREF DMACRO ((VAR VALUE)
(\PUTBASEPTR \VALSPACE (LLSH (\ATOMVALINDEX (QUOTE VAR))
1)
VALUE)))
(PUTPROPS IEQ MACRO ((X Y) (IEQP X Y)))
(PUTPROPS IEQ DMACRO (= . EQ))
)
(SETTEMPLATE (QUOTE SPREADAPPLY*)
(QUOTE (FUNCTIONAL .. EVAL)))
(SETTEMPLATE (QUOTE SPREADAPPLY)
(QUOTE (FUNCTIONAL EVAL . PPE)))
(SETTEMPLATE (QUOTE SETQ.NOREF)
(QUOTE (SET EVAL . PPE)))
(DECLARE: EVAL@COMPILE
(RPAQQ WordsPerPage 256)
(CONSTANTS WordsPerPage)
)
(* END EXPORTED DEFINITIONS)
)
(* atoms)
(DEFINEQ
(GETTOPVAL
[LAMBDA (X) (* bvm: " 2-AUG-83 13:00")
(PROG NIL
(COND
([NOT (LITATOM (OR X (RETURN]
(LISPERROR "ARG NOT LITATOM" X))
(T (RETURN (fetch (LITATOM VALUE) of X])
(SETTOPVAL
[LAMBDA (ATM VAL) (* bvm: " 2-AUG-83 13:00")
(COND
((NOT (LITATOM ATM))
(LISPERROR "ARG NOT LITATOM" ATM))
(T (SELECTQ ATM
(NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(T (OR (EQ VAL T)
(LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(replace (LITATOM VALUE) of ATM with (UNLESSRDSYS VAL (\COPY VAL])
(FSETVAL
[LAMBDA (ATM VAL) (* lmm "18-MAR-82 15:40")
(* SETTOPVAL WITHOUT ERROR CHECKS FOR MAKEINIT ONLY)
(replace (LITATOM VALUE) of ATM with VAL])
(\SETGLOBALVAL.UFN
[LAMBDA (V A) (* lmm " 3-NOV-81 14:48")
(replace (VALINDEX VALUE) of A with V])
(\SETFVAR.UFN
[LAMBDA (V VCELL) (* lmm " 2-NOV-81 22:46")
(replace (VCELL VALUE) of VCELL with V])
(GETPROPLIST
[LAMBDA (ATM) (* lmm " 2-SEP-83 00:27")
(ffetch (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM])
(SETPROPLIST
[LAMBDA (ATM LST) (* lmm " 2-SEP-83 00:28")
(freplace (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM)) with LST])
)
(DEFINEQ
(\MKATOM
[LAMBDA (BASE OFFST LEN) (* lmm "13-FEB-83 13:32")
(PROG ((L 1)
(H 0)
H1 P Q C)
(COND
((ZEROP LEN)
(GO LP)))
(SETQ C (UNLESSRDSYS (\GETBASEBYTE BASE OFFST)
(NTHCHARCODE BASE OFFST)))
[PROGN [UNLESSRDSYS (COND
((AND (IGREATERP 2 LEN)
\OneCharAtomBase)
(RETURN (COND
((IGREATERP C 57)
(\ADDBASE \OneCharAtomBase (IDIFFERENCE C 10)))
((IGREATERP C 47)
(IDIFFERENCE C 48))
(T (\ADDBASE \OneCharAtomBase C]
(UNLESSRDSYS (COND
((AND (ILEQ C (CONSTANT (CHCON1 "9")))
(SETQ P (MKNUMATOM BASE OFFST LEN)))
(* MKNUMATOM returns a number or NIL)
(RETURN P]
(* Calculate first probe)
(SETQ H C)
HASH(COND
((NEQ L LEN)
(SETQ H (LOGAND [IPLUS (IPLUS (LOGAND (SETQ H1 (IPLUS H (LLSH (LOGAND H 4095)
2)))
\AtomHTmask)
(LLSH (LOGAND H1 127)
8))
(UNLESSRDSYS (\GETBASEBYTE BASE (IPLUS OFFST L))
(NTHCHARCODE BASE (IPLUS OFFST L]
\AtomHTmask))
(SETQ L (ADD1 L))
(GO HASH))) (* Lookup and compare)
LP [COND
((NEQ (SETQ P (\GETBASE \AtomHashTable H))
0)
(COND
((UNLESSRDSYS (AND (EQ [fetch (LITATOM PNAMELENGTH) of (SETQ Q (\ADDBASE
\ATOMSPACE
(SUB1 P]
LEN)
(\EQBYTES (fetch (LITATOM PNAMEBASE) of Q)
1 BASE OFFST LEN))
(EQ (\INDEXATOMPNAME (SETQ Q (SUB1 P)))
BASE))
(RETURN Q))
(T (SETQ H (LOGAND (IPLUS H \HashInc)
\AtomHTmask))
(GO LP] (* Not found, must make new atom)
(RETURN (NewAtom BASE OFFST LEN H])
(NewAtom
(LAMBDA (BASE BN LEN H) (* JonL "20-Dec-83 16:04")
(PROG (ATM PB CPP PNP)
(RETURN (UNINTERRUPTABLY
(SETQ ATM \AtomFrLst)
(SETQ PB \NxtPnByte)
(COND
((NOT (ZEROP (LOGAND PB 1)))
(COND
((ZEROP (SETQ PB (LOGAND (ADD1 PB)
(SUB1 \CharsPerPnPage))))
(\GCPNAMES))
(T (SETQ.NOREF \NxtPnByte PB)))))
(SETQ CPP \CurPnPage) (* PNAME will start on this page)
(COND
((ILESSP (IDIFFERENCE \CharsPerPnPage PB)
(ADD1 LEN))
(\GCPNAMES)))
(COND
((EVENP ATM (TIMES 2 WORDSPERPAGE))
(* MDS pages are allocated in two-page chunks now)
(PROG ((PN (FOLDLO ATM WORDSPERPAGE)))
(COND
((IGEQ PN (IDIFFERENCE \LastAtomPage 1))
(* Running out of atom space)
(COND
((EQ ATM (IDIFFERENCE \AtomHTmask 1))
(RAID "No more atoms left"))
((EQ 1 (IMOD ATM (TIMES 2 WORDSPERPAGE)))
(COND
((NOT \STORAGEFULL)
(SETQ \STORAGEFULL T)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T)))))))
(\MAKEMDSENTRY PN (LOGOR \TT.NOREF \LITATOM))
(* Make entry in MDS type table)
(\INITATOMPAGE PN) (* Make Def'n, TopVal, and Plist pages exist, and
initialize)
)))
(\PUTBASEPTR (\ADDBASE (\ADDBASE \PNPSPACE ATM)
ATM)
0
(SETQ PNP (\VAG2 (IPLUS \PnCharsFblock (LRSH CPP 8))
(IPLUS (LLSH (LOGAND CPP 255)
8)
(LRSH PB 1)))))
(* PNAME starts on byte 1 always -
byte 0 is the length)
(\MOVEBYTES BASE BN PNP 1 LEN)
(\PUTBASEBYTE PNP 0 LEN)
(SETQ.NOREF \AtomFrLst (\PUTBASE \AtomHashTable H (ADD1 ATM)))
(COND
((ZEROP (SETQ.NOREF \NxtPnByte (LOGAND (IPLUS PB (LOGAND (IPLUS LEN 2)
65534))
(SUB1 \CharsPerPnPage))))
(\GCPNAMES)))
(\ADDBASE \ATOMSPACE ATM))))))
(\INITATOMPAGE
[LAMBDA (PN) (* lmm " 9-NOV-81 21:20")
(PROG ((OFFSET (UNFOLD PN (ITIMES WORDSPERCELL WORDSPERPAGE)))
J DEFBASE VALBASE) (* PN is in "words" of atom space. OFFSET is offset in words of definition, etc.
space which are in cells)
(* ASSUMES CCODEP BIT IN DEFINITION CELL IS DEFAULT "OFF")
(\NEW4PAGE (\ADDBASE \PNPSPACE OFFSET))
(\NEW4PAGE (SETQ DEFBASE (\ADDBASE \DEFSPACE OFFSET)))
(\NEW4PAGE (\ADDBASE \PLISTSPACE OFFSET))
(\NEW4PAGE (SETQ VALBASE (\ADDBASE \VALSPACE OFFSET)))
(for I from 0 to (SUB1 (ITIMES WORDSPERPAGE 4)) by WORDSPERCELL
do (\PUTBASEPTR VALBASE I (EVQ (QUOTE NOBIND])
(\GCPNAMES
[LAMBDA NIL (* rmk: "23-OCT-82 14:25")
(PROG ((VP (ADD1 \CurPnPage)))
(COND
((IGREATERP VP \LastPnPage)
(RAID "Out of atom p-name space")))
(\NEWPAGE (\VAG2 (IPLUS \PnCharsFblock (LRSH VP 8))
(LLSH (LOGAND VP 255)
8)))
(SETQ.NOREF \NxtPnByte 0)
(SETQ.NOREF \CurPnPage VP])
)
(DEFINEQ
(MAPATOMS
[LAMBDA (FN)
(DECLARE (LOCALVARS . T)) (* lmm "13-FEB-83 13:33")
(PROG ((A 0))
LP (APPLY* FN (\INDEXATOMPNAME A))
(COND
((EQ (SETQ A (ADD1 A))
\AtomFrLst)
(RETURN)))
(GO LP])
)
(DEFINEQ
(INITATOMS
[LAMBDA NIL (* lmm "13-FEB-83 13:27")
(* E (RADIX 10Q))
(* called only under MAKEINIT to initialize the making of atoms)
(PROG (BASE OFFST)
(CREATEPAGES \PNCHARSSPACE 1)
(CREATEPAGES \AtomHashTable \AtomHTpages)
(SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT))
(SETQ BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(SETQ OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING))
(COPYATOM NIL)
(COPYATOM (QUOTE NOBIND))
(for C from 0 to 377Q when (OR (ILESSP C 60Q)
(IGEQ C 72Q))
do (\PUTBASEBYTE BASE OFFST C)
(\MKATOM BASE OFFST 1))
(SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2))
(COPYATOM (FUNCTION \EVALFORM))
(* atom 370Q)
(COPYATOM (FUNCTION \GC.HANDLEOVERFLOW))
(* atom 371Q)
(COPYATOM (FUNCTION \DTESTFAIL))
(* atom 372Q)
(COPYATOM (FUNCTION \OVERFLOWMAKENUMBER))
(* atom 373Q)
(COPYATOM (FUNCTION \MAKENUMBER))
(* atom 374Q)
(COPYATOM (FUNCTION \SETGLOBAL.UFN))
(* atom 375Q)
(COPYATOM (FUNCTION \SETFVAR.UFN))
(* atom 376Q)
(COPYATOM (FUNCTION \GCMAPTABLE))
(* atom 377Q)
(COPYATOM (FUNCTION \INTERPRETER))
(* atom 400Q)
(OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER))
400Q)
(HELP (FUNCTION \INTERPRETER)
" not atom 400Q"))
(COPYATOM (FUNCTION MAKEFLOATNUMBER))
(* atom 401q)
])
(COPYATOM
[LAMBDA (X) (* lmm "13-FEB-83 13:27")
(* this function is only for the use of MAKEINIT, which passes it a real atom to be translated into an atom in the
remote sysout -
\SCRATCHSTRING is initialized in INITATOMS)
(PROG ((N (LOCAL (NCHARS X)))
(BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING)))
[for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
(LOCAL (NTHCHARCODE X I]
(RETURN (\ATOMDEFINDEX (\MKATOM BASE OFFST N])
(UNCOPYATOM
[LAMBDA (N) (* rmk: "23-OCT-82 14:27")
(* this is used only by RDSYS to turn atom numbers into
names)
(COND
((AND \AtomFrLst (IGEQ N \AtomFrLst))
(CONCAT "ATOM#" N))
(T (PROG [(ADDR (\GETBASEPTR \PNPSPACE (LLSH N 1)))
LEN
(STR (OR COPYATOMSTR (SETQ COPYATOMSTR (LOCAL (ALLOCSTRING \PNAMELIMIT]
(SETQ LEN (\GETBASEBYTE ADDR 0))
[for I from 1 to LEN do (LOCAL (RPLSTRING COPYATOMSTR I (FCHARACTER (\GETBASEBYTE
ADDR I]
(RETURN (LOCAL (SUBATOM COPYATOMSTR 1 LEN])
)
(* \PNAMELIMIT is exported as part of CONSTANT below; this gets it copied as well. Note that
both commands must be editted together)
(RPAQQ \PNAMELIMIT 255)
(DEFINEQ
(DEFINEDP
[LAMBDA (A) (* lmm "28-JUL-81 15:47")
(AND (LITATOM A)
(fetch (LITATOM DEFPOINTER) of A])
(PUTD
[LAMBDA (FN DEF FLG) (* lmm "13-OCT-82 09:47")
(SETQ FN (\DTEST FN (QUOTE LITATOM)))
(PROG1 DEF [COND
((AND (NULL FLG)
(ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE)
(NEQ (fetch (CODEARRAY FRAMENAME) of DEF)
FN))
(SETQ DEF (\RENAMEDFN DEF FN]
(\PUTD FN DEF])
(\PUTD
[LAMBDA (FN DEF) (* edited: "19-FEB-82 16:25")
(UNINTERRUPTABLY
(PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))
(DVAL DEF))
(COND
((AND (ARRAYP DVAL)
(EQ (fetch (ARRAYP TYP) of DVAL)
\ST.CODE))
(SETQ DVAL (fetch (ARRAYP BASE) of DVAL))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL))
((LISTP DVAL)
(SETQ DVAL (OR (AND COMPILEATPUTDFLG (\MAKEPSEUDOCODE DVAL FN))
(GO EXPR)))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with T)
(GO CODE))
(T (GO EXPR)))
CODE(replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
(replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (FNHEADER ARGTYPE) of DVAL))
(replace (DEFINITIONCELL FASTP) of DCELL with (ZEROP (fetch (FNHEADER NTSIZE)
of DVAL)))
(replace (DEFINITIONCELL CCODEP) of DCELL with T)
(RETURN DEF)
EXPR(replace CCODEP of DCELL with NIL)
(replace DEFPOINTER of DCELL with DVAL)
(RETURN DEF)))])
(GETD
[LAMBDA (A) (* rmk: "10-DEC-82 10:51")
(COND
((LITATOM A)
(SETQ A (fetch (LITATOM DEFINITIONCELL) of A))
(COND
[(fetch (DEFINITIONCELL CCODEP) of A)
(COND
((fetch (DEFINITIONCELL PSEUDOCODEP) of A)
(\PSEUDOCODE.REALDEF (fetch (DEFINITIONCELL DEFPOINTER) of A)))
(T (SETQ A (fetch (DEFINITIONCELL DEFPOINTER) of A))
(create ARRAYP
BASE ← A
LENGTH ←(UNFOLD (\#BLOCKDATACELLS A)
BYTESPERCELL)
TYP ← \ST.CODE]
(T (fetch (DEFINITIONCELL DEFPOINTER) of A])
(PUTDEFN
[LAMBDA (FN CA SIZE) (* rmk: "23-OCT-82 14:32")
(PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))
[BLOCKINFO (PROGN
(* Reserve enough space. FILECODEBLOCK leaves file pointing at first data word, so BASE is set to that below.
BLOCKINFO is used for setting block trailer.)
(FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL)
(fetch (CODEARRAY ALIGNED) of CA]
(BASE (FILEARRAYBASE)))
(replace (DEFINITIONCELL DEFPOINTER) of DCELL with BASE)
(replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (CODEARRAY ARGTYPE) of CA))
(replace (DEFINITIONCELL FASTP) of DCELL with (ZEROP (fetch (CODEARRAY NTSIZE)
of CA)))
(replace (DEFINITIONCELL CCODEP) of DCELL with T)
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)
[COND
((FMEMB FN LOCKEDFNS)
(\LOCKCELL DCELL 1)
(\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE)
(FOLDHI SIZE BYTESPERWORD))
WORDSPERPAGE]
[COND
((EQ FN (LOCAL (FUNCTION \RESETSTACK)))
(SETQ RESETPTR (FILEARRAYBASE))
(SETQ RESETPC (fetch (CODEARRAY STARTPC) of CA]
(AOUT CA 0 SIZE OUTX (QUOTE CODE))
(BOUTZEROS (MODUP SIZE BYTESPERCELL))
(FILEBLOCKTRAILER BLOCKINFO])
(GETDEFN
[LAMBDA (A) (* lmm "20-AUG-81 12:17")
(fetch (LITATOM DEFPOINTER) of A])
(\SMASHATOM
[LAMBDA (A) (* rmk: "11-OCT-83 13:32")
(replace (LITATOM PNAMELENGTH) of A with 0])
)
(RPAQQ COMPILEATPUTDFLG NIL)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS LITATOM ((PNPCELL (\ADDBASE (\ADDBASE \PNPSPACE (\ATOMPROPINDEX DATUM))
(\ATOMPROPINDEX DATUM)))
(DEFINITIONCELL (\ADDBASE (\ADDBASE \DEFSPACE (\ATOMDEFINDEX DATUM))
(\ATOMDEFINDEX DATUM)))
(PROPCELL (\ADDBASE (\ADDBASE \PLISTSPACE (\ATOMPROPINDEX DATUM))
(\ATOMPROPINDEX DATUM)))
(VALINDEX (\ATOMVALINDEX DATUM)))
(TYPE? (LITATOM DATUM))
[BLOCKRECORD PNPCELL ((PNAMEBASE FULLXPOINTER))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE]
(BLOCKRECORD PROPCELL ((NIL BITS 1)
(GENSYMP FLAG)
(NIL BITS 6)
(PROPLIST POINTER))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(ACCESSFNS VALINDEX ((VCELL (\ADDBASE (\ADDBASE \VALSPACE DATUM)
DATUM))))
]
[DECLARE: EVAL@COMPILE
(BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG)
(FASTP FLAG)
(ARGTYPE BITS 2)
(PSEUDOCODEP FLAG)
(NIL BITS 3)
(DEFPOINTER POINTER)))
(BLOCKRECORD FNHEADER ((STKMIN WORD)
(NA SIGNEDWORD)
(PV SIGNEDWORD)
(STARTPC WORD)
(NIL FLAG)
(NIL FLAG)
(ARGTYPE BITS 2)
(NIL BITS 4)
(#FRAMENAME XPOINTER)
(NTSIZE WORD)
(NLOCALS BYTE)
(FVAROFFSET BYTE))
[ACCESSFNS FNHEADER
((LSTARP (ILESSP (fetch (FNHEADER NA) of DATUM)
0))
(OVERHEADWORDS (PROGN 8))
(ALIGNED (IPLUS (fetch (FNHEADER NTSIZE) of DATUM)
(fetch (FNHEADER OVERHEADWORDS) of T)))
(FIXED NIL (replace (FNHEADER STKMIN) of DATUM
with (IPLUS (UNFOLD (IPLUS (fetch (FNHEADER NA) of DATUM)
(UNFOLD (ADD1 (fetch (FNHEADER
PV)
of DATUM))
CELLSPERQUAD))
WORDSPERCELL)
12 32)))
(NPVARWORDS (UNFOLD (ADD1 (fetch (FNHEADER PV) of DATUM))
WORDSPERQUAD))
(FRAMENAME (fetch (FNHEADER #FRAMENAME) of DATUM)
(UNINTERRUPTABLY
(CHECK (NEQ (\HILOC DATUM)
\STACKHI))
(\DELREF (fetch (FNHEADER #FRAMENAME) of DATUM))
(\ADDREF NEWVALUE)
(replace (FNHEADER #FRAMENAME) of DATUM with NEWVALUE))])
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \ATOMVALINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMDEFINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMPNAMEINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMPROPINDEX DMACRO (= . \LOLOC))
(PUTPROPS \INDEXATOMPNAME DMACRO ((X)
(\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMVAL DMACRO ((X)
(\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMDEF DMACRO ((X)
(\VAG2 \AtomHI X)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \SCRATCHSTRING
COMPILEATPUTDFLG)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \LastAtomPage 127)
(RPAQQ \PNAMELIMIT 255)
(RPAQQ \CharsPerPnPage 512)
(RPAQQ \AtomHTmask 32767)
(RPAQQ \PnCharsFblock 24)
(CONSTANTS (\LastAtomPage 127)
(\PNAMELIMIT 255)
(\CharsPerPnPage 512)
(\AtomHTmask 32767)
(\PnCharsFblock 24))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GETPROPLIST DMACRO ((ATM)
(ffetch (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM)))))
(PUTPROPS SETPROPLIST DMACRO ((ATM LST)
(freplace (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM)) with LST)))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \EQBYTES MACRO (LAMBDA (BASE1 BN1 BASE2 BN2 LEN)
[PROG NIL
LP (COND
((ZEROP LEN)
(RETURN T))
((NEQ (\GETBASEBYTE BASE1 BN1)
(\GETBASEBYTE BASE2 BN2))
(RETURN))
(T (add BN1 1)
(add BN2 1)
(add LEN -1)
(GO LP]))
)
(ADDTOVAR DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL)
)
(* for executing boot expressions when first run)
(DEFINEQ
(\RESETSYSTEMSTATE
[LAMBDA NIL (* rmk: " 5-JUN-81 17:32")
(\KEYBOARDON T)
(\RESETTERMINAL])
(INITIALEVALQT
[LAMBDA NIL (* bvm: "21-APR-83 12:02")
(DECLARE (GLOBALVARS BOOTFILES))
(\SETIOPOINTERS)
(PROG ((RL BOOTFILES)
FL L)
(OR RL (RETURN))
(SIMPLEPRINT "evaluating initial expressions:
") (* BOOTFILES is the list of boot files in reverse order)
R (SETQ FL (CONS (CAR RL)
FL))
(COND
((SETQ RL (CDR RL))
(GO R)))
L1 [COND
([LISTP (SETQ L (GETTOPVAL (CAR FL]
(SIMPLEPRINT (CAR FL)) (* Print the name of the bootfile)
(DSPBOUT (CHARCODE CR))
(PROG NIL
L2 [EVAL (PROG1 (CAR L)
(SETTOPVAL (CAR FL)
(SETQ L (CDR L]
(AND (LISTP L)
(GO L2)))
(SETTOPVAL (CAR FL)
(QUOTE NOBIND]
(COND
((SETQ FL (CDR FL))
(GO L1)))
(SETQ BOOTFILES NIL)
(INTERPRET.REM.CM) (* See if command line has anything to say)
) (* Value is T so that correct value is returned when
this is called from within COPYSYS0)
T])
(SIMPLEPRINT
[LAMBDA (X N) (* lmm "17-MAY-80 20:19")
(COND
[(OR (LITATOM X)
(STRINGP X))
(for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I]
((LISTP X)
(COND
((ZEROP N)
(SIMPLEPRINT "&"))
(T (DSPBOUT (CHARCODE %())
(PROG NIL
LP [SIMPLEPRINT (CAR X)
(SETQ N (COND
((SMALLPOSP N)
(SUB1 N))
(T 3]
(COND
((ZEROP N)
(SIMPLEPRINT " --)"))
((NULL (SETQ X (CDR X)))
(SIMPLEPRINT ")"))
((NLISTP X)
(SIMPLEPRINT " . ")
(SIMPLEPRINT X)
(SIMPLEPRINT ")"))
(T (SIMPLEPRINT " ")
(GO LP])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS RESETFORMS BOOTFILES)
)
(* date/time, stats)
(DEFINEQ
(CLOCK
[LAMBDA (N BOX) (* lmm "15-OCT-82 11:44")
(SELECTQ (OR N 0)
[0 (* time of day in MS)
(\CLOCK0 (COND
((type? FIXP BOX)
BOX)
(T (CREATECELL \FIXP]
(1 (* time this VM was started)
(fetch STARTTIME of \MISCSTATS))
[2 (* run time for this VM)
(\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE
(\BOXIDIFFERENCE [\CLOCK0 (COND
((type? FIXP BOX)
BOX)
(T (CREATECELL \FIXP]
(LOCF (fetch SWAPWAITTIME
of \MISCSTATS)))
(LOCF (fetch KEYBOARDWAITTIME of \MISCSTATS)))
(LOCF (fetch STARTTIME of \MISCSTATS)))
(LOCF (fetch GCTIME of \MISCSTATS]
(3 (* GC TIME)
(fetch GCTIME of \MISCSTATS))
(\ILLEGAL.ARG N])
(DAYTIME
[LAMBDA NIL (* bvm: " 6-DEC-80 16:48")
(* CALLED ONLY BY DATE AND IDATE)
(ALTO.TO.LISP.DATE (DAYTIME0 (CREATECELL \FIXP])
(ALTO.TO.LISP.DATE
[LAMBDA (DATE) (* bvm: "18-FEB-81 00:35")
(* DATE is a 32-bit unsigned integer. To avoid signbit lossage, we subtract MIN.INTEGER from DATE, thereby making
day 0 in the middle of the range. Do this by toggling the high-order bit to avoid integer overflow.)
(LOGXOR DATE -2147483648])
(LISP.TO.ALTO.DATE
[LAMBDA (DATE) (* bvm: "18-FEB-81 00:35")
(LOGXOR DATE -2147483648])
)
(DEFINEQ
(PAGEFAULTS
[LAMBDA NIL (* rrb "13-NOV-80 15:36")
(DECLARE (GLOBALVARS \MISCSTATS))
(fetch PAGEFAULTS of \MISCSTATS])
(\SETTOTALTIME
(LAMBDA NIL (* JonL "17-Dec-83 00:23")
(* updates the total time field of the misc stats page.)
(\BOXIPLUS (LOCF (fetch TOTALTIME of \MISCSTATS))
(CLOCKDIFFERENCE (fetch STARTTIME of \MISCSTATS)))))
(\SERIALNUMBER
[LAMBDA NIL (* rmk: " 9-JUN-81 14:49")
(fetch (IFPAGE SerialNumber) of \InterfacePage])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE)
(LOGXOR DATE -2147483648)))
(PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE)
(LOGXOR DATE -2147483648)))
(* END EXPORTED DEFINITIONS)
)
(* DISMISS is no longer used in system code, when PROCESSWORLD is running. WAITFORINPUT is
called only by ASKUSER and \WAITFORSYSBUFP is used only in TEDIT)
(DEFINEQ
(DISMISS
(LAMBDA (N) (* JonL "19-Dec-83 05:45")
(GLOBALRESOURCE (\DISMISSTIMER-100 \DISMISSTIMER)
(\PUTFIXP \DISMISSTIMER N)
(\BOXIDIFFERENCE \DISMISSTIMER 100)
(PROG ((N-100 (SETUPTIMER \DISMISSTIMER \DISMISSTIMER-100)))
(forDuration N usingTimer \DISMISSTIMER do (if (NOT (TIMEREXPIRED? N-100))
then
(* only run background task if at least 100 msecs left)
(\BACKGROUND))))
N)))
(WAITFORINPUT
[LAMBDA (N) (* bvm: "17-Dec-83 22:21")
(COND
[(FIXP N)
(GLOBALRESOURCE (\DISMISSBOX)
(PROG ((NOW (\CLOCK0 \DISMISSBOX))
(N-100 (IDIFFERENCE N 144Q))
ELAPSED)
LP (COND
((READP T)
(RETURN T))
((NOT (\CLOCKGREATERP NOW N-100))
(* only run background task if at least 144Q msecs left)
(\TTYBACKGROUND))
((\CLOCKGREATERP NOW N) (* Time's up, return with no input)
(RETURN)))
(GO LP]
(N (* Getting OFD avoids time wasted in directory search,
leaves more time for \TTYBACKGROUND)
(bind (OFD ←(\GETOFD N (QUOTE INPUT))) until (OR (READP T)
(READP OFD))
do (\TTYBACKGROUND)))
(T (until (READP T) do (\TTYBACKGROUND])
(\WAITFORSYSBUFP
[LAMBDA (N) (* bvm: "17-Dec-83 22:32")
(COND
[(FIXP N)
(GLOBALRESOURCE (\DISMISSBOX)
(PROG ((NOW (\CLOCK0 \DISMISSBOX)))
LP (COND
((\SYSBUFP)
(RETURN T))
((NOT (TTY.PROCESSP))
(\WAIT.FOR.TTY))
((\CLOCKGREATERP NOW N) (* Time's up, return with no input)
(RETURN))
(T (BLOCK)))
(GO LP]
(T (until (\SYSBUFP)
do (BLOCK)
(\WAIT.FOR.TTY])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \DISMISSBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0)))
(PUTDEF (QUOTE \DISMISSTIMER)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0)))
(PUTDEF (QUOTE \DISMISSTIMER-100)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \DISMISSTIMER-100 \DISMISSTIMER \DISMISSBOX)
)
(RPAQQ \DISMISSTIMER-100 NIL)
(RPAQQ \DISMISSTIMER NIL)
(RPAQQ \DISMISSBOX NIL)
(* Fast functions for moving and clearing storage)
(DEFINEQ
(\MOVEBYTES
[LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (* rmk: "23-OCT-82 14:24")
(* Simple version for bootstrapping)
(COND
((IGREATERP NBYTES 0)
(PROG ((SB (\ADDBASE SBASE (FOLDLO SBYTE BYTESPERWORD)))
(DB (\ADDBASE DBASE (FOLDLO DBYTE BYTESPERWORD)))
SBN DBN NWORDS)
(COND
[(EQ (SETQ SBN (IMOD SBYTE BYTESPERWORD))
(SETQ DBN (IMOD DBYTE BYTESPERWORD)))
(* Can move words)
(COND
((EQ SBN 1)
(\PUTBASEBYTE DB 1 (\GETBASEBYTE SB 1))
(SETQ DB (\ADDBASE DB 1))
(SETQ SB (\ADDBASE SB 1))
(add NBYTES -1)))
(\BLT DB SB (SETQ NWORDS (FOLDLO NBYTES BYTESPERWORD)))
(COND
((EQ (IMOD NBYTES BYTESPERWORD)
1)
(\PUTBASEBYTE (\ADDBASE DB NWORDS)
0
(\GETBASEBYTE (\ADDBASE SB NWORDS)
0]
(T (FRPTQ NBYTES (\PUTBASEBYTE DB (PROG1 DBN (add DBN 1))
(\GETBASEBYTE SB (PROG1 SBN (add SBN 1])
(\BLT
[LAMBDA (DBASE SBASE NWORDS) (* JonL "21-Jan-84 05:21")
(* Generally in ucode -- must guarantee transferral by
moving high-order address first)
(for I from (SUB1 NWORDS) by -1 to 0 do (\PUTBASE (\ADDBASE DBASE I)
0
(\GETBASE (\ADDBASE SBASE I)
0)))
DBASE])
(\ZEROWORDS
[LAMBDA (BASE ENDBASE) (* bvm: "27-NOV-82 17:23")
(* Bootstrapping version of \ZEROWORDS)
[COND
((NOT (PTRGTP BASE ENDBASE))
(COND
([AND (EVENP (\LOLOC BASE))
(NOT (EVENP (\LOLOC ENDBASE] (* Can transfer two words at a time)
(for (B ← BASE) by (\ADDBASE B 2) do (\PUTBASEPTR B 0 NIL)
repeatuntil (EQ (\ADDBASE B 1)
ENDBASE)))
(T (for (B ← BASE) by (\ADDBASE B 1) do (\PUTBASE B 0 0) repeatuntil (EQ B ENDBASE]
BASE])
(\MOVEWORDS
[LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (* bvm: "15-JUN-82 13:56")
(\BLT (\ADDBASE DBASE DOFFSET)
(\ADDBASE SBASE SOFFSET)
NWORDS])
(\ZEROBYTES
[LAMBDA (BASE FIRST LAST) (* bvm: "24-MAY-82 21:46")
(* Redefined by \LONGZEROBYTES)
(FRPTQ (ADD1 (IDIFFERENCE LAST FIRST))
(PROGN (\PUTBASEBYTE BASE FIRST 0)
(add FIRST 1)))
NIL])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTCOPY
(* for MAKEINIT and READSYS)
(ADDTOVAR INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0))
(ADDTOVAR INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES \MOVEBYTES)
(FNS COPYATOM INITATOMS)
(BLOCKS (\MKATOM \MKATOM NewAtom \MOVEBYTES (NOLINKFNS . T))))
(ADDTOVAR EXPANDMACROFNS SMALLPOSP \EQBYTES)
(ADDTOVAR MKI.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 256)
(SETTOPVAL . I.FSETVAL))
(ADDTOVAR RD.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 256)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(NewAtom . ERROR!))
(ADDTOVAR RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \SMASHATOM)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(ADDTOVAR RDVALS (\AtomFrLst))
)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4581 7258 (LISTP 4591 . 4828) (LITATOM 4830 . 5059) (FIXP 5061 . 5326) (STRINGP 5328 .
5575) (SMALLP 5577 . 5822) (SMALLPOSP 5824 . 5937) (NLISTP 5939 . 6146) (ARRAYP 6148 . 6393) (ATOM
6395 . 6667) (FLOATP 6669 . 6914) (NUMBERP 6916 . 7100) (STACKP 7102 . 7256)) (7276 8267 (INITUFNTABLE
7286 . 7880) (\SETUFNENTRY 7882 . 8265)) (8268 8414 (\UNKNOWN.UFN 8278 . 8412)) (10600 12194 (
GETTOPVAL 10610 . 10883) (SETTOPVAL 10885 . 11309) (FSETVAL 11311 . 11543) (\SETGLOBALVAL.UFN 11545 .
11718) (\SETFVAR.UFN 11720 . 11859) (GETPROPLIST 11861 . 12017) (SETPROPLIST 12019 . 12192)) (12195
17557 (\MKATOM 12205 . 14034) (NewAtom 14036 . 16367) (\INITATOMPAGE 16369 . 17147) (\GCPNAMES 17149
. 17555)) (17558 17823 (MAPATOMS 17568 . 17821)) (17824 21194 (INITATOMS 17834 . 19861) (COPYATOM
19863 . 20506) (UNCOPYATOM 20508 . 21192)) (21366 25599 (DEFINEDP 21376 . 21528) (PUTD 21530 . 21931)
(\PUTD 21933 . 23144) (GETD 23146 . 23778) (PUTDEFN 23780 . 25267) (GETDEFN 25269 . 25423) (\SMASHATOM
25425 . 25597)) (29627 31815 (\RESETSYSTEMSTATE 29637 . 29767) (INITIALEVALQT 29769 . 31044) (
SIMPLEPRINT 31046 . 31813)) (31925 33789 (CLOCK 31935 . 32995) (DAYTIME 32997 . 33255) (
ALTO.TO.LISP.DATE 33257 . 33641) (LISP.TO.ALTO.DATE 33643 . 33787)) (33790 34511 (PAGEFAULTS 33800 .
33993) (\SETTOTALTIME 33995 . 34362) (\SERIALNUMBER 34364 . 34509)) (34940 37008 (DISMISS 34950 .
35537) (WAITFORINPUT 35539 . 36495) (\WAITFORSYSBUFP 36497 . 37006)) (37545 40243 (\MOVEBYTES 37555 .
38646) (\BLT 38648 . 39092) (\ZEROWORDS 39094 . 39731) (\MOVEWORDS 39733 . 39919) (\ZEROBYTES 39921 .
40241)))))
STOP