(FILECREATED " 6-Oct-86 21:57:43" {ERIS}<LISPCORE>SOURCES>LLBASIC.;60 67239
changes to: (VARS LLBASICCOMS)
(FUNCTIONS ATOM)
previous date: " 4-Oct-86 17:00:48" {ERIS}<LISPCORE>SOURCES>LLBASIC.;59)
(* "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LLBASICCOMS)
(RPAQQ LLBASICCOMS
((FNS LISTP LITATOM FIXP STRINGP SMALLP NLISTP ARRAYP FLOATP NUMBERP STACKP)
(FUNCTIONS ATOM)
(DECLARE: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR
SETQ.NOREF IEQ)
(TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF)
(CONSTANTS WordsPerPage)))
(COMS (* ; "atoms")
(FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST \ATOMCELL
SETPROPLIST)
(COMS (MACROS \PROPCELL)
(OPTIMIZERS \ATOMCELL GETPROPLIST SETPROPLIST))
(FNS \MKATOM \CREATE.SYMBOL \MKATOM.FULL \INITATOMPAGE)
(FNS MAPATOMS ATOMHASH#PROBES)
(COMS (* ; "For MAKEINIT & TeleRaid")
(FNS INITATOMS COPYATOM UNCOPYATOM))
(COMS (* ; "See \PNAMELIMIT comment below")
(VARS (\PNAMELIMIT 255))
(INITVARS (\PNAMES.IN.BLOCKS?)))
(FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN)
(VARS (COMPILEATPUTDFLG))
(INITVARS (*PACKAGE-FROM-INDEX*))
(DECLARE: DONTCOPY (EXPORT (RECORDS LITATOM SYMBOL VALINDEX VCELL DEFINITIONCELL
FNHEADER PNAMECELL PACKAGEINDEX PNAMEBASE PNAMEINDEX)
(MACROS \DEFCELL \VALCELL \PNAMECELL)
(MACROS \ATOMVALINDEX \ATOMDEFINDEX \ATOMPNAMEINDEX
\ATOMPROPINDEX \INDEXATOMPNAME \INDEXATOMVAL
\INDEXATOMDEF)
(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst
\OneCharAtomBase \PNAMES.IN.BLOCKS? \SCRATCHSTRING
COMPILEATPUTDFLG *PACKAGE-FROM-INDEX*)
(CONSTANTS (\PNAMELIMIT 255)
(\CharsPerPnPage 512))
(* ;; "\PNAMELIMIT is exported but needs to also be a VARS on this file to get it copied. Note that both commands must be edited together. "
)))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS COMPUTE.ATOM.HASH ATOM.HASH.REPROBE)
(ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL))
))
(COMS (* ; "for executing boot expressions when first run")
(FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT)
(GLOBALVARS RESETFORMS BOOTFILES))
(COMS (* ; "stats")
(FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER))
(COMS (* ; "Fast functions for moving and clearing storage")
(FNS \BLT \MOVEBYTES \CLEARWORDS \CLEARBYTES \CLEARCELLS)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS .CLEARNWORDS.))
(COMS (* ; "Obsolete")
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \MOVEWORDS)))
(FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS)))
(LOCALVARS . T)
(DECLARE: DONTCOPY (* ; "For MAKEINIT & TeleRaid")
(ADDVARS (INITVALUES (\AtomFrLst 0))
(INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT \ATOMCELL)
(FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES)
(FNS COPYATOM INITATOMS))
(EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL
\PNAMECELL \PROPCELL \INDEXATOMPNAME)
(MKI.SUBFNS (\PARSE.NUMBER . NILL)
(\MKATOM.FULL . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(SETTOPVAL . I.FSETVAL))
(RD.SUBFNS (\PARSE.NUMBER . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(\CREATE.SYMBOL . VNOSUCHATOM))
(RDCOMS (FNS UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN
\ATOMCELL)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(RDVALS (\AtomFrLst))))
(PROP FILETYPE LLBASIC)))
(DEFINEQ
(LISTP
[LAMBDA (X) (* bvm: "30-Jan-85 10:56")
(* usually done in microcode)
(AND (EQ (NTYPX X)
\LISTP)
(COND
((EQ CDRCODING 0)
T)
(T (* Check that it is not a list page
header. This is mostly for benefit of
teleraid)
(NEQ (fetch (POINTER WORDINPAGE) of X)
0)))
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)
(\TYPEMASK.UFN X (LRSH \TT.FIXP 8])
(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])
(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])
(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")
(\TYPEMASK.UFN X (LRSH \TT.NUMBERP 8])
(STACKP
[LAMBDA (X) (* lmm "10-MAR-81 15:13")
(SELECTC (NTYPX X)
(\STACKP X)
NIL])
)
(DEFINLINE ATOM (X) (OR (NULL X)
(AND (\TYPEMASK.UFN X 8)
T)))
(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 DMACRO (OPENLAMBDA (A)
(PROG ((LO (IPLUS16 (\GETBASE A 1)
1)))
(DECLARE (LOCALVARS LO))
(* Increment double word at A by 1)
(\PUTBASE A 1 LO)
(COND ((EQ LO 0)
(\PUTBASE A 0 (ADD1 (\GETBASE A 0))))))))
(PUTPROPS IPLUS16 MACRO ((X Y)
(* Kludge to do 16-bit plus)
(\LOLOC (\ADDBASE X Y))))
(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0))))
(PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF , (CADAR X)
,
(CADR X)))))
(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 VAL)
(\PUTBASEPTR (LOCF (fetch (LITATOM VALUE)
of
(QUOTE VAR)))
0 VAL)))
(PROGN (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) (* edited: " 3-Apr-85 16:38")
(fetch (LITATOM VALUE) of X])
(SETTOPVAL
[LAMBDA (ATM VAL) (* edited: " 3-Apr-85 19:37")
(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) (* edited: " 3-Apr-85 19:36")
(* SETTOPVAL WITHOUT ERROR CHECKS FOR
MAKEINIT ONLY)
(replace (LITATOM VALUE) of ATM with VAL])
(\SETGLOBALVAL.UFN
[LAMBDA (V A) (* bvm: " 6-Jun-85 11:54")
(replace (VALINDEX VALUE) of A with V])
(\SETFVAR.UFN
[LAMBDA (V VCELL) (* edited: " 3-Apr-85 16:40")
(replace (VCELL VALUE) of VCELL with V])
(GETPROPLIST
[LAMBDA (ATM) (* edited: " 3-Apr-85 16:40")
(\GETBASEPTR (\PROPCELL ATM)
0])
(\ATOMCELL
[LAMBDA (X N) (* lmm "20-Mar-86 16:30")
(LET [(LOC (SELECTC N
(\DEF.HI (\ATOMDEFINDEX X))
(\VAL.HI (\ATOMVALINDEX X))
(\PLIST.HI (\ATOMPROPINDEX X))
(\PNAME.HI (\ATOMPNAMEINDEX X))
(SHOULDNT]
(\ADDBASE (\VAG2 N LOC)
LOC])
(SETPROPLIST
[LAMBDA (ATM LST) (* edited: " 3-Apr-85 16:41")
(replace (LITATOM PROPLIST) of ATM with LST])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \PROPCELL MACRO ((ATOM)
(\ATOMCELL ATOM (CONSTANT \PLIST.HI))))
)
(DEFOPTIMIZER \ATOMCELL (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X))))
(COND
(CE (BQUOTE ((OPCODES ATOMCELL.N , (CAR CE))
,
(CAR X))))
(T (QUOTE IGNOREMACRO)))))
(DEFOPTIMIZER GETPROPLIST (X) (BQUOTE (\GETBASEPTR (\PROPCELL (\, X))
0)))
(DEFOPTIMIZER SETPROPLIST (ATM LST) (BQUOTE (\RPLPTR (\PROPCELL (\, ATM))
0
(\, LST))))
(DEFINEQ
(\MKATOM
[LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (* bvm: " 3-Aug-86 15:24")
(PROG ([FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST to (SUB1 (IPLUS OFFST LEN))
suchthat (IGREATERP (\GETBASEFAT BASE I)
\MAXTHINCHAR]
HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE)
(* Because FATCHARSEENP is used in an
EQ check later, it must be NIL or T
only, hence the (NOT
(NULL ...)))
(COND
((EQ LEN 0) (* The Zero-length atom has hash code
zero)
(SETQ HASH 0)
(SETQ FIRSTBYTE 255)
(GO LP)))
(SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST)
(NTHCHARCODE BASE OFFST))) (* Grab the first character of the
atom)
[UNLESSRDSYS (COND
[(AND (EQ LEN 1)
(ILEQ FIRSTCHAR \MAXTHINCHAR)
\OneCharAtomBase) (* The one-character atoms live in
well known places, no need to hash)
(RETURN (COND
((IGREATERP FIRSTCHAR (CHARCODE "9"))
(\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10)))
((IGEQ FIRSTCHAR (CHARCODE "0"))
(* These one-character atoms are
integers. Sigh)
(IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
(T (\ADDBASE \OneCharAtomBase FIRSTCHAR]
((AND (NOT NONNUMERICP)
(ILEQ FIRSTCHAR (CHARCODE "9"))
(SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE)))
(* \PARSE.NUMBER returns a number or
NIL)
(RETURN HASHENT] (* Calculate first probe)
(SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (* First byte is used to compute hash
and reprobe. Use lower order byte of
first character, since chances are
that has the most information)
(COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP) (* Build a hash value for this atom
from the PNAME)
LP (* Top of the probe-and-compare-PNAMEs
loop.)
[COND
((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
(* HASHENT is one greater than the
atom number, so that atom zero can be
stored. Go from atom number to pname,
compare strings)
(COND
((UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH)
of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE)
of (SETQ ATM# (SUB1 HASHENT]
LEN)
[EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE
PNAMEFATPADDINGBYTE
) of PNBASE))
(* Extra memory references to get the FATPNAMEP bit, so do a quick and dirty
heuristic, based on the fact that the second byte of a fatpname is always
0--wouldn't be worth it if the fatbit were more easily accessible)
)
(ffetch (LITATOM FATPNAMEP)
of (\ADDBASE \ATOMSPACE ATM#]
(COND
[FATCHARSEENP (* FATCHARSEENP=T now implies that
both the probe and target are fat)
(for B1 from 1 to LEN as B2 from OFFST
always (* Loop thru the characters in the
putative atom and the existing PNAME,
to see if they're the same)
(EQ (\GETBASEFAT PNBASE B1)
(\GETBASEFAT BASE B2]
[FATP (* The incoming string is fat, but
there are no fat characters in the
PNAME.)
(for B1 from 1 to LEN as B2 from OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASEFAT BASE B2]
(T (* Both the incoming string of chars
and the PNAME are thin.)
(for B1 from 1 to LEN as B2 from OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASETHIN BASE B2]
(EQ (\INDEXATOMPNAME (SETQ ATM# (SUB1 HASHENT)))
BASE))
(RETURN (\ADDBASE \ATOMSPACE ATM#)))
(T (* Doesn't match, so reprobe.
Want reprobe to be variable,
preferably independent of primary
probe.)
[SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH
FIRSTBYTE]
(GO LP] (* Not found, must make new atom)
(RETURN (UNINTERRUPTABLY
(LET ((NEWATOM (\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP)))
[UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM]
NEWATOM))])
(\CREATE.SYMBOL
[LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (* bvm: "13-Jun-86 17:25")
(* * Creates a new symbol whose pname is as indicated.
FATP means the presented string is fat, while FATCHARSEENP means that there
actually is a fat char in there (otherwise we will store a thin pname) -
Must be called UNINTERRUPTABLY and the caller is responsible for interning the
symbol wherever it belongs)
(LET ([PNBASE (\ALLOCBLOCK (COND
(FATCHARSEENP (* Allocate us a bunch of word-sized
chars in pname space)
(FOLDHI (ADD1 LEN)
WORDSPERCELL))
(T (* Allocation is in CELLS)
(FOLDHI (ADD1 LEN)
BYTESPERCELL]
PB CPP ATM)
(COND
((EVENP (SETQ ATM \AtomFrLst)
\MDSIncrement) (* MDS pages are allocated in two-page
chunks now)
(PROG ((PN (FOLDLO ATM WORDSPERPAGE)))
(COND
((IGEQ PN (IDIFFERENCE \LastAtomPage 1))
(\MKATOM.FULL)))
(\MAKEMDSENTRY PN (LOGOR \TT.NOREF \TT.ATOM \LITATOM))
(* Make entry in MDS type table)
(\INITATOMPAGE PN) (* Make Def'n, TopVal, and Plist pages
exist, and initialize)
))
((EQ ATM \MaxAtomFrLst) (* This test is fast)
(\MP.ERROR \MP.ATOMSFULL "No more atoms left")))
(replace (PNAMEINDEX PNAMEBASE) of ATM with PNBASE) (* PNAME starts on byte 1 always -
byte 0 is the length)
(COND
(FATCHARSEENP (\BLT (\ADDBASE PNBASE 1)
(\ADDBASE BASE OFFSET)
LEN))
[FATP (for I from OFFSET as J from 1 to LEN do (\PUTBASETHIN PNBASE J (\GETBASEFAT BASE I
]
(T (\MOVEBYTES BASE OFFSET PNBASE 1 LEN)))
(replace (PNAMEBASE PNAMELENGTH) of PNBASE with LEN)
(COND
((NOT \IN.MAKEINIT) (* Make the pname block permanent,
since the replace above did not addref
it)
(\ADDREF PNBASE)))
(SETQ \AtomFrLst (ADD1 ATM))
(SETQ ATM (\ADDBASE \ATOMSPACE ATM))
(COND
(FATCHARSEENP (freplace (LITATOM FATPNAMEP) of ATM with T)))
ATM])
(\MKATOM.FULL
[LAMBDA NIL (* bvm: " 7-May-86 12:25")
(* * Cause a STORAGEFULL interrupt on the first atom of the penultimate page --
that should give "early" warning.)
(DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
(COND
((NOT \STORAGEFULL)
(SETQ \STORAGEFULL T)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T)))
NIL])
(\INITATOMPAGE
[LAMBDA (PN) (* bvm: "18-Jan-85 16:02")
(PROG ((OFFSET (UNFOLD PN WORDSPERPAGE))
VALBASE)
(* PN is the page number of the first atom.
OFFSET is the first atom. Have to double that to get offsets in \DEFSPACE etc.
Atoms, like everything, are allocated in double pages, so the 4 spaces have to
be allocated in quad pages)
(* * assumes CCODEP bit in definition cell is default "OFF" , so it's ok to
have all def pages zero to start)
(\NEW4PAGE (\ADDBASE2 \PNPSPACE OFFSET))
(\NEW4PAGE (\ADDBASE2 \DEFSPACE OFFSET))
(\NEW4PAGE (\ADDBASE2 \PLISTSPACE OFFSET))
(\NEW4PAGE (SETQ VALBASE (\ADDBASE2 \VALSPACE OFFSET)))
(FRPTQ (ITIMES CELLSPERPAGE 4) (* Initialize value pages to value
NOBIND)
(\PUTBASEPTR VALBASE 0 (EVQ (QUOTE NOBIND)))
(SETQ VALBASE (\ADDBASE VALBASE WORDSPERCELL])
)
(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])
(ATOMHASH#PROBES
[LAMBDA (STRING) (* bvm: " 8-Jul-86 21:50")
(* * Looks up STRING (a string or litatom) in atom hash table.
If found, returns number of probes needed to find it, a minimum of one.
If not found, returns NIL)
(PROG (DESIREDATOM# BASE OFFST LEN FIRSTBYTE FIRSTCHAR HASH HASHENT PNBASE REPROBE FATCHARSEENP
FATP)
[COND
((LITATOM STRING)
(SETQ BASE (ffetch (LITATOM PNAMEBASE) of STRING))
(SETQ OFFST 1)
(SETQ LEN (ffetch (LITATOM PNAMELENGTH) of STRING))
(SETQ FATP (SETQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP) of STRING)))
(SETQ DESIREDATOM# (\LOLOC STRING)))
(T [SETQ BASE (ffetch (STRINGP BASE) of (SETQ STRING (MKSTRING STRING]
(SETQ OFFST (ffetch (STRINGP OFFST) of STRING))
(SETQ LEN (ffetch (STRINGP LENGTH) of STRING))
[COND
((SETQ FATP (ffetch (STRINGP FATSTRINGP) of STRING))
(SETQ FATCHARSEENP (for C infatstring STRING when (IGREATERP C \MAXTHINCHAR)
do (RETURN T]
(OR (ILEQ LEN \PNAMELIMIT)
(RETURN]
(SETQ FIRSTCHAR (\GETBASECHAR FATP BASE OFFST))
(SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))
(COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)
(RETURN (for PROBES from 1 until (EQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
do (COND
([COND
(DESIREDATOM# (EQ DESIREDATOM# (SUB1 HASHENT)))
(T (AND (EQ [fetch (PNAMEBASE PNAMELENGTH)
of (SETQ PNBASE (fetch (PNAMEINDEX PNAMEBASE)
of (SUB1 HASHENT]
LEN)
[EQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP)
of (\ADDBASE \ATOMSPACE (SUB1 HASHENT]
(COND
[FATCHARSEENP (* FATCHARSEENP=T now implies that
both the probe and target are fat)
(for B1 from 1 to LEN as B2 from OFFST
always (* Loop thru the characters in the
putative atom and the existing PNAME,
to see if they're the same)
(EQ (\GETBASEFAT PNBASE B1)
(\GETBASEFAT BASE B2]
[FATP (* The incoming string is fat, but
there are no fat characters in the
PNAME.)
(for B1 from 1 to LEN as B2 from OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASEFAT BASE B2]
(T (* Both the incoming string of chars
and the PNAME are thin.)
(for B1 from 1 to LEN as B2 from OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASETHIN BASE B2]
(RETURN PROBES))) (* Doesn't match, so reprobe.
Want reprobe to be variable,
preferably independent of primary
probe.)
(SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH
FIRSTBYTE])
)
(* ; "For MAKEINIT & TeleRaid")
(DEFINEQ
(INITATOMS
[LAMBDA NIL (* bvm: "30-Sep-86 22:59")
(* ;;
"called only under MAKEINIT to initialize the making of atoms")
(CREATEPAGES \AtomHashTable \AtomHTpages)
(SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT))
(* ; "\SCRATCHSTRING created in remote space simply to make renaming simple. Could smash it to NIL inside init.sysout")
(LET ((BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING)))(* (CREATEPAGES \PNCHARSSPACE 1))
(COPYATOM NIL) (* ; "NIL is atom 0")
(COPYATOM (QUOTE NOBIND)) (* ; "atom 1")
(* ;;
"Now make the single character atoms -- all thin chars except the digits")
(for C from 0 to 255 when (OR (ILESSP C (CHARCODE 0))
(IGREATERP C (CHARCODE 9))) do (\PUTBASEBYTE BASE OFFST C)
(\MKATOM BASE OFFST 1))
(SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2)) (* ; "= (CHARACTER 0) -- for FCHARACTER")
(COPYATOM (FUNCTION \EVALFORM)) (* ; "atom 256-10+2 = 248")
(COPYATOM (FUNCTION \GC.HANDLEOVERFLOW)) (* ; "atom 249")
(COPYATOM (FUNCTION \DTEST.UFN)) (* ; "atom 250")
(COPYATOM (FUNCTION \OVERFLOWMAKENUMBER)) (* ; "atom 251")
(COPYATOM (FUNCTION \MAKENUMBER)) (* ; "atom 252")
(COPYATOM (FUNCTION \SETGLOBAL.UFN)) (* ; "atom 253")
(COPYATOM (FUNCTION \SETFVAR.UFN)) (* ; "atom 254")
(COPYATOM (FUNCTION \GCMAPTABLE)) (* ; "atom 255")
(COPYATOM (FUNCTION \INTERPRETER)) (* ; "atom 256")
(OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER))
256)
(HELP (FUNCTION \INTERPRETER)
" not atom 400Q"])
(COPYATOM
[LAMBDA (X) (* bvm: "30-Sep-86 23:01")
(* ;; "this function is only for the use of MAKEINIT, which passes it a local atom to be translated into an atom in the remote sysout.")
[ALLOCAL (LET ((PKG (SYMBOL-PACKAGE X))) (* ;
"SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world")
(if (NEQ PKG *INTERLISP-PACKAGE*)
then (* ; "Kludge time. We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix")
(if (EQ PKG *KEYWORD-PACKAGE*)
then (SETQ X (CONCAT ":" X))
elseif (FIND-EXACT-SYMBOL X *INTERLISP-PACKAGE*)
then (* ;; "Symbol is homed somewhere else but is accessible in Interlisp package. These are symbols that are going to get moved from IL to CL when the sysout starts up, so no translation needed. This is a messy test, which is why we test for Interlisp and keyword packages first.")
elseif (EQ PKG *LISP-PACKAGE*)
then (* ;;
"Symbol lives in CL and not available in IL, so add prefix")
(SETQ X (CONCAT "CL:" X))
elseif (STRING-EQUAL (PACKAGE-NAME PKG)
"SYSTEM")
then (* ;; "SYSTEM = SI package. All internal for now.")
(SETQ X (CONCAT "SI::" X))
else (HELP "Can only translate symbols in IL, CL, SI and keywords" X]
(LET ((N (LOCAL (NCHARS X)))
(BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING)))
(* ; "\SCRATCHSTRING is initialized in INITATOMS")
[for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
(LOCAL (NTHCHARCODE X I]
(\ATOMDEFINDEX (\MKATOM BASE OFFST N])
(UNCOPYATOM
[LAMBDA (N) (* bvm: "22-Jan-85 11:37")
(* this is used only by RDSYS to turn
atom numbers into names)
(PROG ((ADDR (\GETBASEPTR (\ADDBASE2 \PNPSPACE N)
0))
[STR (OR COPYATOMSTR (SETQ COPYATOMSTR (LOCAL (ALLOCSTRING \PNAMELIMIT]
LEN)
(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])
)
(* ; "See \PNAMELIMIT comment below")
(RPAQQ \PNAMELIMIT 255)
(RPAQ? \PNAMES.IN.BLOCKS? )
(DEFINEQ
(\DEFINEDP
[LAMBDA (A) (* edited: " 3-Apr-85 19:45")
(AND (LITATOM A)
(fetch (LITATOM DEFPOINTER) of A)
T])
(PUTD
[LAMBDA (FN DEF FLG) (* bvm: " 7-Jul-86 17:06")
(PROG1 DEF [COND
((AND (NULL FLG)
(TYPEP DEF (QUOTE COMPILED-CLOSURE))
(NEQ (fetch (COMPILED-CLOSURE FRAMENAME) of DEF)
FN)) (* Definition being stored has a
different frame name, so fix it)
(SETQ DEF (\RENAMEDFN DEF FN]
(\PUTD FN DEF])
(\PUTD
[LAMBDA (FN DEF) (* bvm: " 8-Jul-86 16:34")
(LET ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN)))
(UNINTERRUPTABLY
(PROG ((DVAL DEF)
CODEBASE)
(COND
[(TYPEP DVAL (QUOTE COMPILED-CLOSURE))
(SETQ CODEBASE (fetch (COMPILED-CLOSURE FNHEADER) of DVAL))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)
(COND
((fetch (COMPILED-CLOSURE ENVIRONMENT) of DVAL)
(* Full closure, have to store it as
non-ccodep)
(replace CCODEP of DCELL with NIL)
(GO CLOSURE))
(T (* Strip out code base)
(SETQ DVAL CODEBASE]
((AND (ARRAYP DVAL)
(EQ (fetch (ARRAYP TYP) of DVAL)
\ST.CODE)) (* Code array -- only from the code
reader or compiler)
(SETQ CODEBASE (SETQ DVAL (fetch (ARRAYP BASE) of DVAL)))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL))
((AND COMPILEATPUTDFLG (LISTP DVAL))
[SETQ DVAL (SETQ CODEBASE (OR (\MAKEPSEUDOCODE DVAL FN)
(GO EXPR]
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with T))
(T (GO EXPR)))
CODE
(replace (DEFINITIONCELL CCODEP) of DCELL with T)
CLOSURE
(replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (FNHEADER ARGTYPE)
of CODEBASE))
(replace (DEFINITIONCELL FASTP) of DCELL with (EQ 0 (fetch (FNHEADER NTSIZE)
of CODEBASE)))
(replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
(RETURN DEF)
EXPR
(replace (DEFINITIONCELL DEFCELLFLAGS) of DCELL with 0)
(replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
(RETURN DEF)))])
(GETD
[LAMBDA (A) (* bvm: " 7-Jul-86 16:46")
(COND
((LITATOM A)
(LET ((A (fetch (LITATOM DEFINITIONCELL) of A)))
(COND
((NOT (fetch (DEFINITIONCELL CCODEP) of A))
(fetch (DEFINITIONCELL DEFPOINTER) of A))
((fetch (DEFINITIONCELL PSEUDOCODEP) of A)
(\PSEUDOCODE.REALDEF (fetch (DEFINITIONCELL DEFPOINTER) of A)))
(T (create COMPILED-CLOSURE
FNHEADER ← (fetch (DEFINITIONCELL DEFPOINTER) of A])
(PUTDEFN
[LAMBDA (FN CA SIZE) (* edited: " 3-Apr-85 19:55")
(* special version of PUTD that runs
only at MAKEINIT time)
(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 (EQ (fetch (CODEARRAY NTSIZE) of CA)
0))
(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))) (* special kludge to remember where
\RESETSTACK is in the MAKEINIT)
(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])
)
(RPAQQ COMPILEATPUTDFLG NIL)
(RPAQ? *PACKAGE-FROM-INDEX* )
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS LITATOM ((DEFINITIONCELL (\DEFCELL DATUM))
(PROPCELL (\PROPCELL DATUM))
(VCELL (\VALCELL DATUM))
(PNAMECELL (\PNAMECELL DATUM)))
(* * VCELL can also be accessed directly from a value index via the record
VALINDEX (as in \SETGLOBALVAL.UFN) -
Similarly, PNAMEINDEX accesses PNAMECELL for use by \MKATOM and UNCOPYATOM)
(TYPE? (LITATOM DATUM))
(BLOCKRECORD PROPCELL ((NIL BITS 1)
(GENSYMP FLAG)
(FATPNAMEP FLAG)
(NIL BITS 5)
(PROPLIST POINTER))))
(SYNONYM SYMBOL (LITATOM))
(ACCESSFNS VALINDEX ((VCELL (\ADDBASE2 \VALSPACE DATUM))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG)
(FASTP FLAG)
(ARGTYPE BITS 2)
(PSEUDOCODEP FLAG)
(NIL BITS 3)
(DEFPOINTER POINTER))
(BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BYTE)
(NIL POINTER))))
(BLOCKRECORD FNHEADER ((STKMIN WORD)
(NA SIGNEDWORD)
(PV SIGNEDWORD)
(STARTPC WORD)
(NIL FLAG)
(NIL FLAG)
(ARGTYPE BITS 2)
(NIL BITS 3)
(CLOSUREP FLAG)
(#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))))))
(BLOCKRECORD PNAMECELL ((PACKAGEINDEX BYTE)
(PNAMEBASE XPOINTER))
(BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER)
(*
"Replacing this smashes PACKAGEINDEX to 0")
))
(ACCESSFNS PNAMECELL ((PACKAGE (AREF *PACKAGE-FROM-INDEX* (FETCH (PNAMECELL
PACKAGEINDEX
)
OF DATUM))
(REPLACE (PNAMECELL PACKAGEINDEX) OF DATUM
WITH (IF (NULL NEWVALUE)
THEN *UNINTERNED-PACKAGE-INDEX*
ELSE (PACKAGE-INDEX NEWVALUE)))))))
(ACCESSFNS PACKAGEINDEX ((PACKAGE (AREF *PACKAGE-FROM-INDEX* DATUM))))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE) (* Length is always here, be the pname
thin or fat)
(PNAMEFATPADDINGBYTE BYTE) (* This byte is zero for fat pnames so
that the pname chars are word-aligned)
))
(ACCESSFNS PNAMEINDEX ((PNAMECELL (\ADDBASE (\VAG2 \PNAME.HI (\LOLOC DATUM))
(\LOLOC DATUM)))))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \DEFCELL MACRO ((ATOM)
(\ATOMCELL ATOM \DEF.HI)))
(PUTPROPS \VALCELL MACRO ((ATOM)
(\ATOMCELL ATOM \VAL.HI)))
(PUTPROPS \PNAMECELL MACRO ((ATOM)
(\ATOMCELL ATOM \PNAME.HI)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \ATOMVALINDEX DMACRO ((X)
(\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMDEFINDEX DMACRO ((X)
(\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMPNAMEINDEX DMACRO ((X)
(\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMPROPINDEX DMACRO ((X)
(\LOLOC (\DTEST X (QUOTE LITATOM)))))
(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
(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \PNAMES.IN.BLOCKS?
\SCRATCHSTRING COMPILEATPUTDFLG *PACKAGE-FROM-INDEX*)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \PNAMELIMIT 255)
(RPAQQ \CharsPerPnPage 512)
(CONSTANTS (\PNAMELIMIT 255)
(\CharsPerPnPage 512))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS COMPUTE.ATOM.HASH MACRO ((BASE OFFST LEN FIRSTBYTE FATP)
(* Sets variable HASH to atom hash of indicated string)
(SETQ HASH (LLSH FIRSTBYTE 8))
(for CHAR# from (ADD1 OFFST)
to
(SUB1 (IPLUS OFFST LEN))
do
(SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH
(IPLUS16
HASH
(LLSH (LOGAND HASH 4095)
2)))
(LLSH (LOGAND HASH 255)
8))
(UNLESSRDSYS (COND
(FATP (LOGAND (\GETBASEFAT
BASE CHAR#)
255))
(T (\GETBASETHIN BASE CHAR#))
)
(NTHCHARCODE BASE CHAR#)))))))
(PUTPROPS ATOM.HASH.REPROBE MACRO ((HASH FIRSTBYTE)
(LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH)))))
)
(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) (* bvm: "13-Feb-85 22:25")
(COND
[(OR (LITATOM X)
(STRINGP X))
(for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I]
((LISTP X)
(COND
((EQ N 0)
(SIMPLEPRINT "&"))
(T (DSPBOUT (CHARCODE %())
(PROG NIL
LP [SIMPLEPRINT (CAR X)
(SETQ N (COND
((SMALLPOSP N)
(SUB1 N))
(T 3]
(COND
((EQ N 0)
(SIMPLEPRINT " --)"))
((NULL (SETQ X (CDR X)))
(SIMPLEPRINT ")"))
((NLISTP X)
(SIMPLEPRINT " . ")
(SIMPLEPRINT X)
(SIMPLEPRINT ")"))
(T (SIMPLEPRINT " ")
(GO LP])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS RESETFORMS BOOTFILES)
)
(* ; "stats")
(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])
)
(* ; "Fast functions for moving and clearing storage")
(DEFINEQ
(\BLT
[LAMBDA (DBASE SBASE NWORDS) (* lmm "30-Mar-85 05:43")
(* Generally in ucode --
must guarantee transferral by moving
high-order address first)
(PROG [(NN (CONSTANT (EXPT 2 14]
(RETURN (COND
((GREATERP NWORDS NN) (* dorado has microcode only for up to
2↑15)
(\BLT (\ADDBASE DBASE NN)
(\ADDBASE SBASE NN)
(DIFFERENCE NWORDS NN))
(\BLT DBASE SBASE NN))
(T (for I from (SUB1 NWORDS) by -1 to 0 do (\PUTBASE DBASE I (\GETBASE SBASE I))
)
DBASE])
(\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])
(\CLEARWORDS
[LAMBDA (BASE NWORDS) (* bvm: "20-Feb-85 12:30")
(PROG1 BASE (while (IGREATERP NWORDS 32767) do (* BLT wants NWORDS to be small.
We play it safe by keeping the count
smaller than 2↑15, avoiding a Dorado
uCode bug)
(.CLEARNWORDS. BASE 32768)
(SETQ BASE (\ADDBASE BASE 32768))
(SETQ NWORDS (IDIFFERENCE NWORDS 32768)))
(COND
((IGREATERP NWORDS 0)
(.CLEARNWORDS. BASE NWORDS])
(\CLEARBYTES
[LAMBDA (BASE OFFST NBYTES) (* bvm: "29-Jan-85 18:56")
(COND
((IGREATERP NBYTES 0)
(COND
((ODDP OFFST)
(\PUTBASEBYTE BASE OFFST 0)
(add OFFST 1)
(add NBYTES -1))) (* OFFST is now even)
(SETQ BASE (\ADDBASE BASE (FOLDLO OFFST BYTESPERWORD)))
(COND
((ODDP NBYTES) (* Final byte to be zeroed)
(\PUTBASEBYTE BASE (SUB1 NBYTES)
0))) (* Now all we have to do is zero the
word-aligned part in the middle)
(\CLEARWORDS BASE (FOLDLO NBYTES BYTESPERWORD])
(\CLEARCELLS
[LAMBDA (BASE NCELLS) (* bvm: "20-Feb-85 12:51")
[while (IGEQ NCELLS (FOLDLO 32767 WORDSPERCELL)) do (* Keep the BLTs small.
See \CLEARWORDS)
(.CLEARNWORDS. BASE 32768)
(SETQ BASE (\ADDBASE BASE 32768))
(SETQ NCELLS (IDIFFERENCE NCELLS
(FOLDLO 32768
WORDSPERCELL]
(COND
((IGREATERP NCELLS 0)
(SETQ NCELLS (UNFOLD NCELLS WORDSPERCELL))
(.CLEARNWORDS. BASE NCELLS])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS)
(* Clear NWORDS words starting at base. Assumes NWORDS is smallp
and greater than zero. Compiler refuses to optimize out an
IGREATERP test here, so push back to caller)
(\PUTBASE BASE (SUB1 NWORDS)
0)
(COND ((NEQ NWORDS 1)
(\BLT BASE (\ADDBASE BASE 1)
(SUB1 NWORDS))))
NIL))
)
)
(* ; "Obsolete")
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
(\BLT (\ADDBASE DBASE DOFFSET)
(\ADDBASE SBASE SOFFSET)
NWORDS)))
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(\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: "29-Jan-85 19:12")
(\CLEARBYTES BASE FIRST (ADD1 (IDIFFERENCE LAST FIRST])
(\ZEROWORDS
[LAMBDA (BASE ENDBASE) (* bvm: "29-Jan-85 12:54")
(while (IGREATERP (\HILOC ENDBASE)
(\HILOC BASE)) do (\CLEARWORDS BASE (IDIFFERENCE (SUB1 WORDSPERSEGMENT)
(\LOLOC BASE)))
(\PUTBASE (\VAG2 (\HILOC BASE)
(SUB1 WORDSPERSEGMENT))
0 0) (* Done this way to avoid non-SMALLP
arithmetic when (\LOLOC BASE) = 0)
(SETQ BASE (\VAG2 (ADD1 (\HILOC BASE))
0)))
(PROG [(DIF (IDIFFERENCE (\LOLOC ENDBASE)
(\LOLOC BASE]
(COND
((IGEQ DIF 0)
(\PUTBASE BASE 0 0)
(\CLEARWORDS (\ADDBASE BASE 1)
DIF])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTCOPY
(ADDTOVAR INITVALUES (\AtomFrLst 0))
(ADDTOVAR INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT \ATOMCELL)
(FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES)
(FNS COPYATOM INITATOMS))
(ADDTOVAR EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL \PNAMECELL
\PROPCELL \INDEXATOMPNAME)
(ADDTOVAR MKI.SUBFNS (\PARSE.NUMBER . NILL)
(\MKATOM.FULL . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(SETTOPVAL . I.FSETVAL))
(ADDTOVAR RD.SUBFNS (\PARSE.NUMBER . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(\CREATE.SYMBOL . VNOSUCHATOM))
(ADDTOVAR RDCOMS (FNS UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(ADDTOVAR RDVALS (\AtomFrLst))
)
(PUTPROPS LLBASIC FILETYPE COMPILE-FILE)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5613 8357 (LISTP 5623 . 6310) (LITATOM 6312 . 6554) (FIXP 6556 . 6793) (STRINGP 6795 .
7052) (SMALLP 7054 . 7309) (NLISTP 7311 . 7524) (ARRAYP 7526 . 7781) (FLOATP 7783 . 8038) (NUMBERP
8040 . 8190) (STACKP 8192 . 8355)) (11559 13580 (GETTOPVAL 11569 . 11728) (SETTOPVAL 11730 . 12102) (
FSETVAL 12104 . 12462) (\SETGLOBALVAL.UFN 12464 . 12638) (\SETFVAR.UFN 12640 . 12813) (GETPROPLIST
12815 . 12978) (\ATOMCELL 12980 . 13395) (SETPROPLIST 13397 . 13578)) (14435 27479 (\MKATOM 14445 .
22527) (\CREATE.SYMBOL 22529 . 25814) (\MKATOM.FULL 25816 . 26326) (\INITATOMPAGE 26328 . 27477)) (
27480 32577 (MAPATOMS 27490 . 27803) (ATOMHASH#PROBES 27805 . 32575)) (32618 38308 (INITATOMS 32628 .
35054) (COPYATOM 35056 . 37605) (UNCOPYATOM 37607 . 38306)) (38417 44881 (\DEFINEDP 38427 . 38633) (
PUTD 38635 . 39215) (\PUTD 39217 . 41996) (GETD 41998 . 42651) (PUTDEFN 42653 . 44719) (GETDEFN 44721
. 44879)) (53885 56918 (\RESETSYSTEMSTATE 53895 . 54055) (INITIALEVALQT 54057 . 55802) (SIMPLEPRINT
55804 . 56916)) (57012 57834 (PAGEFAULTS 57022 . 57220) (\SETTOTALTIME 57222 . 57655) (\SERIALNUMBER
57657 . 57832)) (57898 62853 (\BLT 57908 . 58919) (\MOVEBYTES 58921 . 60296) (\CLEARWORDS 60298 .
61151) (\CLEARBYTES 61153 . 61981) (\CLEARCELLS 61983 . 62851)) (64027 65468 (\MOVEWORDS 64037 . 64241
) (\ZEROBYTES 64243 . 64418) (\ZEROWORDS 64420 . 65466)))))
STOP