(FILECREATED "11-Mar-86 19:10:11" {ERIS}<LISPCORE>BVM>LLBASIC.;1 56247
changes to: (RECORDS LITATOM)
previous date: " 8-Jul-85 20:44:33" {ERIS}<LISPCORE>SOURCES>LLBASIC.;47)
(* 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 ATOM FLOATP NUMBERP STACKP)
(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)
(MACROS \ATOMCELL)
(FNS \MKATOM \MKATOM.NEW \MKATOM.FULL \INITATOMPAGE \GCPNAMES)
(FNS MAPATOMS ATOMHASH#PROBES)
(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))
(DECLARE: DONTCOPY (EXPORT (RECORDS LITATOM VALINDEX VCELL DEFINITIONCELL
PNAMECELL FNHEADER PNAMEBASE PNAMEINDEX)
(MACROS \DEFCELL \VALCELL \PROPCELL \PNAMECELL)
(MACROS \ATOMVALINDEX \ATOMDEFINDEX
\ATOMPNAMEINDEX \ATOMPROPINDEX
\INDEXATOMPNAME \INDEXATOMVAL
\INDEXATOMDEF)
(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage
\AtomFrLst \OneCharAtomBase
\PNAMES.IN.BLOCKS? \SCRATCHSTRING
COMPILEATPUTDFLG)
(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.)
(MACROS GETPROPLIST SETPROPLIST)))
(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.))
(* Obsolete:)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \MOVEWORDS))
(FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS))
(LOCALVARS . T)
(DECLARE: DONTCOPY (ADDVARS (INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0)
(\PNAMES.IN.BLOCKS?))
(INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT
\ATOMCELL)
(FNS \MKATOM \MKATOM.NEW \INITATOMPAGE \GCPNAMES
\MOVEBYTES)
(FNS COPYATOM INITATOMS))
(EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH
ATOM.HASH.REPROBE \DEFCELL \VALCELL \PNAMECELL
\PROPCELL \INDEXATOMPNAME)
(MKI.SUBFNS (MKNUMATOM . NILL)
(\MKATOM.FULL . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(SETTOPVAL . I.FSETVAL))
(RD.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(\MKATOM.NEW . VNOSUCHATOM))
(RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL
GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(RDVALS (\AtomFrLst])
(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 10Q])
(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])
(ATOM
[LAMBDA (X) (* lmm "10-MAR-81 15:08")
(* compiles open)
(\MACRO.MX (ATOM X))])
(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 10Q])
(STACKP
[LAMBDA (X) (* lmm "10-MAR-81 15:13")
(SELECTC (NTYPX X)
(\STACKP X)
NIL])
)
(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")
(fetch (LITATOM PROPLIST) of ATM])
(\ATOMCELL
[LAMBDA (X N) (* edited: " 3-Apr-85 22:52")
(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 \ATOMCELL DMACRO (X (LET [(CE (CONSTANTEXPRESSIONP (CADR X]
(COND [CE (BQUOTE ((OPCODES ATOMCELL.N , (CAR CE))
,
(CAR X]
(T (QUOTE IGNOREMACRO]
)
(DEFINEQ
(\MKATOM
[LAMBDA (BASE OFFST LEN FATP) (* lmm " 7-Jul-85 13:12")
(PROG [HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE
(FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST to (SUB1 (IPLUS OFFST LEN))
suchthat (IGREATERP (\GETBASEFAT BASE I)
\MAXTHINCHAR]
(* 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 (ILEQ FIRSTCHAR (CHARCODE "9"))
(SETQ HASHENT (MKNUMATOM BASE OFFST LEN FATP)))
(* MKNUMATOM 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 (\MKATOM.NEW BASE OFFST LEN HASH FATP FATCHARSEENP])
(\MKATOM.NEW
[LAMBDA (BASE OFFST LEN HASH FATP FATCHARSEENP) (* bvm: "28-Jun-85 14:21")
(DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
(PROG (ATM PB CPP PNBASE)
[COND
(\PNAMES.IN.BLOCKS? (SETQ 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]
(RETURN (UNINTERRUPTABLY
(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")))
[COND
((NOT \PNAMES.IN.BLOCKS?)
(SETQ PB \NxtPnByte)
(COND
((ODDP PB)
(SHOULDNT "ODDP value in \NxtPnByte ")))
(SETQ CPP \CurPnPage) (* PNAME will start on this page)
(COND
([ILESSP (IDIFFERENCE \CharsPerPnPage PB)
(COND
(FATCHARSEENP (UNFOLD (ADD1 LEN)
BYTESPERWORD))
(T (ADD1 LEN] (* Not enough space left on this pname page to hold all
the characters for the new atom.)
(\GCPNAMES)))
(SETQ PNBASE (\VAG2 (IPLUS \PnCharsFirstSegment (LRSH CPP 8))
(IPLUS (LLSH (LOGAND CPP 255)
8)
(LRSH PB 1]
(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 OFFST)
LEN))
[FATP (for I from OFFST as J from 1 to LEN do (\PUTBASETHIN PNBASE J
(\GETBASEFAT
BASE I]
(T (\MOVEBYTES BASE OFFST PNBASE 1 LEN)))
(replace (PNAMEBASE PNAMELENGTH) of PNBASE with LEN)
(\PUTBASE \AtomHashTable HASH (SETQ \AtomFrLst (ADD1 ATM)))
(* Ugly, they just both happen to want to be set to
(ADD1 ATM))
[COND
(\PNAMES.IN.BLOCKS? (* Make the pname block permanent, since the replace
above did not addref it)
(\ADDREF PNBASE))
(T
(* * Would like to use (CEIL (ADD1 LEN) BYTESPERWORD) in the following, but it will produce a
(LOGAND ... -2) and the DLion 4K control store doesn't have negative arithmetic in ucode.)
(SETQ.NOREF \NxtPnByte (IMOD (IPLUS PB (LOGAND (IPLUS LEN 2)
65534))
\CharsPerPnPage))
(COND
((EQ 0 \NxtPnByte)
(\GCPNAMES]
(SETQ ATM (\ADDBASE \ATOMSPACE ATM))
(COND
(FATCHARSEENP (freplace (LITATOM FATPNAMEP) of ATM with T)))
ATM)])
(\MKATOM.FULL
[LAMBDA NIL (* bvm: "13-Feb-85 22:23")
(* * Cause a STORAGEFULL interrupt on the first atom of the penultimate page -- that should give "early" warning.)
(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])
(\GCPNAMES
[LAMBDA NIL (* bvm: "13-Dec-84 17:15")
(PROG ((VP (ADD1 \CurPnPage)))
(COND
((IGREATERP VP \LastPnPage)
(\MP.ERROR \MP.PNAMESFULL "Out of atom p-name space"))
(T [\NEWPAGE (create POINTER
PAGE# ←(IPLUS VP (UNFOLD \PnCharsFirstSegment PAGESPERSEGMENT]
(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])
(ATOMHASH#PROBES
[LAMBDA (STRING) (* rmk: "11-Apr-85 22:20")
(* * 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))
[if (SETQ FATP (ffetch (STRINGP FATSTRINGP) of STRING))
then (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 377Q))
(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])
)
(DEFINEQ
(INITATOMS
(LAMBDA NIL (* lmm "22-Mar-85 12:30") (* 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
\DTEST.UFN)) (* 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
[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) (* 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) (* edited: " 3-Apr-85 19:54")
(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: " 3-Apr-85 19:54")
(LET ((DCELL (FETCH (LITATOM DEFINITIONCELL) OF FN)))
(UNINTERRUPTABLY
(PROG ((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 (EQ 0 (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) (* edited: " 3-Apr-85 19:54")
(COND
((LITATOM A)
(LET ((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) (* 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)
(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)
(NUMERICPNAMEP FLAG)
(NIL BITS 4)
(PROPLIST POINTER))))
(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 PNAMECELL ((PNAMEBASE FULLXPOINTER)))
(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))])
(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 \PROPCELL MACRO ((ATOM)
(\ATOMCELL ATOM \PLIST.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)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \PNAMELIMIT 255)
(RPAQQ \CharsPerPnPage 512)
(CONSTANTS (\PNAMELIMIT 255)
(\CharsPerPnPage 512))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GETPROPLIST DMACRO ((X)
(fetch (LITATOM PROPLIST)
of X)))
(PUTPROPS SETPROPLIST DMACRO ((ATM LST)
(replace (LITATOM PROPLIST)
of ATM with LST)))
)
(* 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 (if (GREATERP NWORDS NN)
then (* dorado has microcode only for up to 2↑15)
(\BLT (\ADDBASE DBASE NN)
(\ADDBASE SBASE NN)
(DIFFERENCE NWORDS NN))
(\BLT DBASE SBASE NN)
else (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
(DECLARE: EVAL@COMPILE
(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
(\BLT (\ADDBASE DBASE DOFFSET)
(\ADDBASE SBASE SOFFSET)
NWORDS)))
)
)
(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 (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0)
(\PNAMES.IN.BLOCKS?))
(ADDTOVAR INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT \ATOMCELL)
(FNS \MKATOM \MKATOM.NEW \INITATOMPAGE \GCPNAMES \MOVEBYTES)
(FNS COPYATOM INITATOMS))
(ADDTOVAR EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL \PNAMECELL
\PROPCELL \INDEXATOMPNAME)
(ADDTOVAR MKI.SUBFNS (MKNUMATOM . 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 (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(\MKATOM.NEW . VNOSUCHATOM))
(ADDTOVAR RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(ADDTOVAR RDVALS (\AtomFrLst))
)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7261 10009 (LISTP 7271 . 7796) (LITATOM 7798 . 8027) (FIXP 8029 . 8272) (STRINGP 8274
. 8521) (SMALLP 8523 . 8768) (NLISTP 8770 . 8977) (ARRAYP 8979 . 9224) (ATOM 9226 . 9446) (FLOATP
9448 . 9693) (NUMBERP 9695 . 9851) (STACKP 9853 . 10007)) (13056 14918 (GETTOPVAL 13066 . 13221) (
SETTOPVAL 13223 . 13600) (FSETVAL 13602 . 13890) (\SETGLOBALVAL.UFN 13892 . 14062) (\SETFVAR.UFN 14064
. 14233) (GETPROPLIST 14235 . 14397) (\ATOMCELL 14399 . 14737) (SETPROPLIST 14739 . 14916)) (15283
26233 (\MKATOM 15293 . 20467) (\MKATOM.NEW 20469 . 24316) (\MKATOM.FULL 24318 . 24735) (\INITATOMPAGE
24737 . 25773) (\GCPNAMES 25775 . 26231)) (26234 29850 (MAPATOMS 26244 . 26497) (ATOMHASH#PROBES 26499
. 29848)) (29851 32328 (INITATOMS 29861 . 31015) (COPYATOM 31017 . 31660) (UNCOPYATOM 31662 . 32326))
(32433 36985 (\DEFINEDP 32443 . 32635) (PUTD 32637 . 33032) (\PUTD 33034 . 34356) (GETD 34358 . 35030
) (PUTDEFN 35032 . 36827) (GETDEFN 36829 . 36983)) (45213 47477 (\RESETSYSTEMSTATE 45223 . 45353) (
INITIALEVALQT 45355 . 46630) (SIMPLEPRINT 46632 . 47475)) (47567 48288 (PAGEFAULTS 47577 . 47770) (
\SETTOTALTIME 47772 . 48139) (\SERIALNUMBER 48141 . 48286)) (48348 52090 (\BLT 48358 . 49114) (
\MOVEBYTES 49116 . 50207) (\CLEARWORDS 50209 . 50808) (\CLEARBYTES 50810 . 51536) (\CLEARCELLS 51538
. 52088)) (53187 54365 (\MOVEWORDS 53197 . 53383) (\ZEROBYTES 53385 . 53564) (\ZEROWORDS 53566 .
54363)))))
STOP