(FILECREATED "20-Feb-85 12:51:09" {ERIS}<LISPCORE>SOURCES>LLBASIC.;21 47580
changes to: (FNS \CLEARCELLS \CLEARWORDS)
previous date: "13-Feb-85 22:28:46" {ERIS}<LISPCORE>SOURCES>LLBASIC.;19)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLBASICCOMS)
(RPAQQ LLBASICCOMS ((FNS LISTP LITATOM FIXP STRINGP SMALLP 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 IPLUS16 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 \MKATOM.NEW \MKATOM.FULL \INITATOMPAGE \GCPNAMES)
(FNS MAPATOMS ATOMHASH#PROBES)
(FNS INITATOMS COPYATOM UNCOPYATOM)
(COMS (* See ATOMEXPORTS comment below)
(VARS (\PNAMELIMIT 255))
(INITVARS (\PNAMES.IN.BLOCKS?)))
(FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN \SMASHATOM)
(VARS (COMPILEATPUTDFLG))
(DECLARE: DONTCOPY (EXPORT * ATOMEXPORTS))
(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 (* "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 (* Fast functions for moving and clearing storage)
(FNS \BLT \MOVEBYTES \CLEARWORDS \CLEARBYTES \CLEARCELLS)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS .CLEARNWORDS.))
(* Obsolete:)
(FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS))
(LOCALVARS . T)
(DECLARE: DONTCOPY (COMS * LLBMAKEINITCOMS))))
(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)
(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])
(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 (* bvm: "13-Feb-85 22:24")
(CREATEPAGES \UFNTable \UFNTableSize NIL T)
(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)
(if (LISTP (fetch (OPCODE LEVADJ) of X))
then (CADR (fetch (OPCODE LEVADJ) of X))
else (IDIFFERENCE (IPLUS 1 (COND
((EQ (fetch (OPCODE OPNARGS) of X)
0)
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 (* bvm: "23-Mar-84 15:52")
(\MP.ERROR \MP.UNKNOWN.UFN "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 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))))
(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 (fetch (LITATOM VCELL)
of
(QUOTE VAR))
0 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) (* lmm " 9-Jul-84 17:34")
(ffetch (LITATOM VALUE) of (\DTEST X (QUOTE LITATOM])
(SETTOPVAL
[LAMBDA (ATM VAL) (* lmm " 9-Jul-84 17:47")
(SELECTQ (\DTEST ATM (QUOTE LITATOM))
(NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(T (OR (EQ VAL T)
(LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(freplace (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) (* bvm: "29-Jan-85 23:40")
(PROG (HASH HASHENT ATM# PNBASE FIRSTCHAR REPROBE)
(COND
((EQ LEN 0) (* The Zero-length atom has hash code zero)
(SETQ HASH 0)
(SETQ FIRSTCHAR 255)
(GO LP)))
(SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASEBYTE BASE OFFST)
(NTHCHARCODE BASE OFFST)))
[UNLESSRDSYS (COND
[(AND (EQ LEN 1)
\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)))
(* MKNUMATOM returns a number or NIL)
(RETURN HASHENT] (* Calculate first probe)
(COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTCHAR) (* Lookup and compare)
LP [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 [fetch (PNAMEBASE PNAMELENGTH) of (SETQ PNBASE
(fetch (PNAMEINDEX
PNAMEBASE)
of (SETQ ATM#
(SUB1 HASHENT]
LEN)
(for N from LEN by -1 until (EQ N 0) as B1 from 1 as B2
from OFFST always (EQ (\GETBASEBYTE PNBASE B1)
(\GETBASEBYTE 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
FIRSTCHAR]
(GO LP] (* Not found, must make new atom)
(RETURN (\MKATOM.NEW BASE OFFST LEN HASH])
(\MKATOM.NEW
[LAMBDA (BASE OFFST LEN HASH) (* bvm: "13-Feb-85 22:24")
(DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
(PROG (ATM PB CPP PNBASE)
(if \PNAMES.IN.BLOCKS?
then (SETQ PNBASE (\ALLOCBLOCK (FOLDHI (ADD1 LEN)
BYTESPERCELL)
UNBOXEDBLOCK.GCT)))
(RETURN (UNINTERRUPTABLY
(if (EVENP (SETQ ATM \AtomFrLst)
\MDSIncrement)
then (* 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 \LITATOM))
(* Make entry in MDS type table)
(\INITATOMPAGE PN) (* Make Def'n, TopVal, and Plist pages exist, and
initialize)
)
elseif (EQ ATM \MaxAtomFrLst)
then (* This test is fast)
(\MP.ERROR \MP.ATOMSFULL "No more atoms left"))
[if (NOT \PNAMES.IN.BLOCKS?)
then (SETQ PB \NxtPnByte)
(if (ODDP PB)
then (SHOULDNT "ODDP value in \NxtPnByte "))
(SETQ CPP \CurPnPage) (* PNAME will start on this page)
(if (ILESSP (IDIFFERENCE \CharsPerPnPage PB)
(ADD1 LEN))
then (* 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)
(\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))
(if \PNAMES.IN.BLOCKS?
then (* Make the pname block permanent, since the replace
above did not addref it)
(\ADDREF PNBASE)
else
(* * 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))
(if (EQ 0 \NxtPnByte)
then (\GCPNAMES)))
(\ADDBASE \ATOMSPACE 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) (* bvm: "31-Jan-85 14:58")
(* * 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 FIRSTCHAR HASH HASHENT PNBASE REPROBE)
[COND
((LITATOM STRING)
(SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH) 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))
(OR (ILEQ LEN \PNAMELIMIT)
(RETURN]
(SETQ FIRSTCHAR (\GETBASEBYTE BASE OFFST))
(COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTCHAR)
(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)
(for N from LEN by -1 until (EQ N 0) as B1 from 1 as B2
from OFFST always (EQ (\GETBASEBYTE PNBASE B1)
(\GETBASEBYTE 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
FIRSTCHAR])
)
(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) (* 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 ATOMEXPORTS comment below)
(RPAQQ \PNAMELIMIT 255)
(RPAQ? \PNAMES.IN.BLOCKS? )
(DEFINEQ
(\DEFINEDP
[LAMBDA (A) (* lmm "10-Apr-84 15:13")
(AND (LITATOM A)
(fetch (LITATOM DEFPOINTER) of A)
T])
(PUTD
[LAMBDA (FN DEF FLG) (* lmm "18-Apr-84 17:43")
(SETQ FN (\DTEST (OR FN (AND DEF (\LISPERROR DEF "ATTEMPT TO PUTD NIL")))
(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) (* JonL " 1-May-84 11:55")
(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 (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) (* 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) (* bvm: "13-Feb-85 22:25")
(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)))
(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
(RPAQQ ATOMEXPORTS ((RECORDS LITATOM VCELL VALINDEX)
(RECORDS DEFINITIONCELL FNHEADER)
(RECORDS PNAMEINDEX PNAMECELL PNAMEBASE)
(E (* MACROS should go away in favor of record access))
(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)))
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS LITATOM ((PNAMEINDEX (\ATOMPROPINDEX DATUM))
(DEFINITIONCELL (\ADDBASE2 \DEFSPACE (\ATOMDEFINDEX DATUM)))
(PROPCELL (\ADDBASE2 \PLISTSPACE (\ATOMPROPINDEX DATUM)))
(VALINDEX (\ATOMVALINDEX DATUM)))
(* * VALINDEX is a record containing VCELL analogous to DEFINITIONCELL etc. Done this way so you can also manipulate
the valindex directly, 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))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(ACCESSFNS VALINDEX ((VCELL (\ADDBASE2 \VALSPACE 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
(ACCESSFNS PNAMEINDEX ((PNAMECELL (\ADDBASE2 \PNPSPACE DATUM))))
(BLOCKRECORD PNAMECELL ((PNAMEBASE FULLXPOINTER)))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE)))
]
(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
(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 [(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 COMPUTE.ATOM.HASH MACRO [(BASE OFFST LEN FIRSTCHAR)
(* Sets variable HASH to atom hash of indicated string)
(SETQ HASH (LLSH FIRSTCHAR 8))
(for BYTE# from 1 while (NEQ BYTE# LEN)
do (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH
(IPLUS16 HASH
(LLSH (LOGAND HASH
4095)
2)))
(LLSH (LOGAND HASH 255)
8))
(UNLESSRDSYS (\GETBASEBYTE BASE
(IPLUS OFFST
BYTE#))
(NTHCHARCODE BASE
(IPLUS OFFST
BYTE#])
(PUTPROPS ATOM.HASH.REPROBE MACRO [(HASH FIRSTCHAR)
(LOGAND 63 (LOGOR 1 (LOGXOR FIRSTCHAR 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)
)
(* "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)
)
(* Fast functions for moving and clearing storage)
(DEFINEQ
(\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])
(\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:)
(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
(RPAQQ LLBMAKEINITCOMS [(ADDVARS (INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0)
(\PNAMES.IN.BLOCKS?))
(INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT)
(FNS \MKATOM \MKATOM.NEW \INITATOMPAGE \GCPNAMES
\MOVEBYTES)
(FNS COPYATOM INITATOMS))
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM
GETDEFN PUTDEFN FSETVAL)))
(EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE)
(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 \SMASHATOM)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(RDVALS (\AtomFrLst])
(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)
(FNS \MKATOM \MKATOM.NEW \INITATOMPAGE \GCPNAMES \MOVEBYTES)
(FNS COPYATOM INITATOMS))
(ADDTOVAR DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM
GETDEFN PUTDEFN FSETVAL)))
(ADDTOVAR EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE)
(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 \SMASHATOM)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(ADDTOVAR RDVALS (\AtomFrLst))
)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2366 5216 (LISTP 2376 . 2901) (LITATOM 2903 . 3132) (FIXP 3134 . 3399) (STRINGP 3401 .
3648) (SMALLP 3650 . 3895) (NLISTP 3897 . 4104) (ARRAYP 4106 . 4351) (ATOM 4353 . 4625) (FLOATP 4627
. 4872) (NUMBERP 4874 . 5058) (STACKP 5060 . 5214)) (5236 6446 (INITUFNTABLE 5246 . 6059) (
\SETUFNENTRY 6061 . 6444)) (6447 6641 (\UNKNOWN.UFN 6457 . 6639)) (9168 10615 (GETTOPVAL 9178 . 9353)
(SETTOPVAL 9355 . 9730) (FSETVAL 9732 . 9964) (\SETGLOBALVAL.UFN 9966 . 10139) (\SETFVAR.UFN 10141 .
10280) (GETPROPLIST 10282 . 10438) (SETPROPLIST 10440 . 10613)) (10616 18549 (\MKATOM 10626 . 13491) (
\MKATOM.NEW 13493 . 16632) (\MKATOM.FULL 16634 . 17051) (\INITATOMPAGE 17053 . 18089) (\GCPNAMES 18091
. 18547)) (18550 20800 (MAPATOMS 18560 . 18813) (ATOMHASH#PROBES 18815 . 20798)) (20801 24151 (
INITATOMS 20811 . 22838) (COPYATOM 22840 . 23483) (UNCOPYATOM 23485 . 24149)) (24256 28638 (\DEFINEDP
24266 . 24450) (PUTD 24452 . 24914) (\PUTD 24916 . 26122) (GETD 26124 . 26756) (PUTDEFN 26758 . 28306)
(GETDEFN 28308 . 28462) (\SMASHATOM 28464 . 28636)) (34106 36370 (\RESETSYSTEMSTATE 34116 . 34246) (
INITIALEVALQT 34248 . 35523) (SIMPLEPRINT 35525 . 36368)) (36473 38337 (CLOCK 36483 . 37543) (DAYTIME
37545 . 37803) (ALTO.TO.LISP.DATE 37805 . 38189) (LISP.TO.ALTO.DATE 38191 . 38335)) (38338 39059 (
PAGEFAULTS 38348 . 38541) (\SETTOTALTIME 38543 . 38910) (\SERIALNUMBER 38912 . 39057)) (39403 42833 (
\BLT 39413 . 39857) (\MOVEBYTES 39859 . 40950) (\CLEARWORDS 40952 . 41551) (\CLEARBYTES 41553 . 42279)
(\CLEARCELLS 42281 . 42831)) (43363 44541 (\MOVEWORDS 43373 . 43559) (\ZEROBYTES 43561 . 43740) (
\ZEROWORDS 43742 . 44539)))))
STOP