(FILECREATED "18-AUG-83 12:35:41" {PHYLUM}<LISPCORE>SOURCES>LLBASIC.;41 145730Q
changes to: (VARS LLBASICCOMS)
previous date: " 2-AUG-83 13:00:59" {PHYLUM}<LISPCORE>SOURCES>LLBASIC.;40)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT LLBASICCOMS)
(RPAQQ LLBASICCOMS [(FNS LISTP LITATOM FIXP STRINGP SMALLP SMALLPOSP NLISTP ARRAYP ATOM FLOATP
NUMBERP STACKP)
[COMS (* ufns)
(FNS INITUFNTABLE SETUFNENTRY)
(FNS \UNKNOWN.UFN)
(DECLARE: DONTCOPY (RECORDS UFNENTRY)
(ADDVARS (INEWCOMS (FNS INITUFNTABLE SETUFNENTRY)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS INITUFNTABLE SETUFNENTRY]
(DECLARE: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 SMALLPOSP SETXVAR
SETQ.NOREF IEQ)
(TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF)
(CONSTANTS WordsPerPage)))
[COMS (* atoms)
(FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST
SETPROPLIST)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES)
(FNS MAPATOMS)
(FNS INITATOMS COPYATOM UNCOPYATOM)
(VARS (\PNAMELIMIT 177Q))
(FNS DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN)
(VARS (COMPILEATPUTDFLG))
[DECLARE: DONTCOPY (EXPORT (RECORDS LITATOM VCELL VALINDEX)
(RECORDS DEFINITIONCELL FNHEADER)
(E (* MACROS should go away in favor of record
access))
(MACROS \ATOMVALINDEX \ATOMDEFINDEX
\ATOMPNAMEINDEX \ATOMPROPINDEX
\INDEXATOMPNAME \INDEXATOMVAL
\INDEXATOMDEF)
(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage
\AtomFrLst \OneCharAtomBase
\SCRATCHSTRING COMPILEATPUTDFLG)
(CONSTANTS (\LastAtomPage 177Q)
\PNAMELIMIT
(\CharsPerPnPage 1000Q)
(\AtomHTmask 77777Q)
(\PnCharsFblock 30Q]
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \EQBYTES)
(ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN
PUTDEFN FSETVAL]
(COMS (* for executing boot expressions when first run)
(FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT)
(GLOBALVARS RESETFORMS BOOTFILES))
[COMS (* date/time, stats)
(FNS CLOCK CLOCKDIFFERENCE \CLOCKGREATERP \SECONDSCLOCKGREATERP DAYTIME
ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE DISMISS PAGEFAULTS \SETTOTALTIME
\SERIALNUMBER)
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (PROP MACRO ALTO.TO.LISP.DATE
LISP.TO.ALTO.DATE)))
(GLOBALRESOURCES (\CLOCKDIFBOX (CREATECELL \FIXP))
(\DISMISSBOX (CREATECELL \FIXP]
[COMS (* Fast functions for moving and clearing storage, using BitBlt)
(FNS \INITSTORAGEBBTS \CREATESTORAGEBBT \CLEARSTORAGE \MOVESTORAGE
\MOVEBYTES \LONGMOVEBYTES \BLT \LONGWORDBLT \ZEROWORDS \LONGZEROWORDS
\MOVEWORDS \ZEROBYTES \LONGZEROBYTES)
(GLOBALVARS \MOVESTORAGEBBT \CLEARSTORAGEBBT)
(DECLARE: DONTEVAL@LOAD DOCOPY (INITRECORDS BitBltTable)
(P (\INITSTORAGEBBTS)))
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS WORDS.TO.BYTES WORDS.TO.BITS
BYTES.TO.BITS BYTES.LEFT.IN.SEGMENT
WORDS.LEFT.IN.SEGMENT)
(CONSTANTS (MaxSegWord 177777Q)
(MAXWORDBLT 3777Q)
(\BITBLT.CUTOFF 10Q]
(LOCALVARS . T)
(DECLARE: DONTCOPY (* for MAKEINIT and READSYS)
(ADDVARS (INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0))
(INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
[INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES
\MOVEBYTES)
(FNS COPYATOM INITATOMS)
(BLOCKS (\MKATOM \MKATOM NewAtom \MOVEBYTES
(NOLINKFNS . T]
(EXPANDMACROFNS SMALLPOSP \EQBYTES)
(MKI.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 400Q)
(SETTOPVAL . I.FSETVAL))
(RD.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 400Q)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(NewAtom . ERROR!))
(RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST
SETTOPVAL GETDEFN)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(RDVALS (\AtomFrLst])
(DEFINEQ
(LISTP
[LAMBDA (X) (* lmm "10-MAR-81 15:01")
(* usually done in microcode)
(AND (EQ (NTYPX X)
\LISTP)
X])
(LITATOM
[LAMBDA (X) (* lmm "10-MAR-81 15:05")
(* compiles open to NTYPX check)
(EQ (NTYPX X)
\LITATOM])
(FIXP
[LAMBDA (X) (* lmm "10-MAR-81 15:08")
(* compiles open to TYPEPs)
(SELECTC (NTYPX X)
((LIST \SMALLP \FIXP)
X)
NIL])
(STRINGP
[LAMBDA (X) (* lmm "10-MAR-81 15:09")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\STRINGP X)
NIL])
(SMALLP
[LAMBDA (X) (* lmm "10-MAR-81 15:10")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\SMALLP X)
NIL])
(SMALLPOSP
[LAMBDA (X) (* lmm " 9-NOV-81 21:21")
(EQ (\HILOC X)
\SmallPosHi])
(NLISTP
[LAMBDA (X) (* lmm "10-MAR-81 15:07")
(* compiles open)
(NOT (LISTP X])
(ARRAYP
[LAMBDA (X) (* lmm "10-MAR-81 15:11")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\ARRAYP X)
NIL])
(ATOM
[LAMBDA (X) (* lmm "10-MAR-81 15:08")
(* compiles open)
(SELECTC (NTYPX X)
((LIST \SMALLP \FIXP \FLOATP \LITATOM)
T)
NIL])
(FLOATP
[LAMBDA (X) (* lmm "10-MAR-81 15:11")
(* compiles open to TYPEP)
(SELECTC (NTYPX X)
(\FLOATP X)
NIL])
(NUMBERP
[LAMBDA (X) (* lmm "10-MAR-81 15:12")
(SELECTC (NTYPX X)
((LIST \FIXP \SMALLP \FLOATP)
X)
NIL])
(STACKP
[LAMBDA (X) (* lmm "10-MAR-81 15:13")
(SELECTC (NTYPX X)
(\STACKP X)
NIL])
)
(* ufns)
(DEFINEQ
(INITUFNTABLE
[LAMBDA NIL (* lmm " 9-NOV-81 13:35")
(for I from 0 to 255 do (SETUFNENTRY I (QUOTE \UNKNOWN.UFN)
0 0))
(for X in \OPCODES when (fetch (OPCODE UFNFN) of X)
do (SETUFNENTRY (fetch (OPCODE OP#) of X)
(fetch (OPCODE UFNFN) of X)
(IDIFFERENCE (IPLUS 1 (COND
((ZEROP (fetch (OPCODE OPNARGS) of X))
0)
(T 1)))
(fetch (OPCODE LEVADJ) of X))
(fetch (OPCODE OPNARGS) of X])
(SETUFNENTRY
[LAMBDA (INDEX FN NARGS NEXTRA)
(* lmm "13-FEB-83 13:08")
(SETQ INDEX (\ADDBASE \UFNTable (LLSH INDEX 1)))
(replace (UFNENTRY FNINDEX) of INDEX with (\ATOMDEFINDEX FN))
(replace (UFNENTRY NEXTRA) of INDEX with NEXTRA)
(replace (UFNENTRY NARGS) of INDEX with NARGS])
)
(DEFINEQ
(\UNKNOWN.UFN
[LAMBDA NIL (* lmm "27-JUN-80 22:12")
(RAID "Compiler/microcode error: unknown UFN"])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD UFNENTRY ((FNINDEX WORD)
(NEXTRA BYTE)
(NARGS BYTE)))
]
(ADDTOVAR INEWCOMS (FNS INITUFNTABLE SETUFNENTRY))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS INITUFNTABLE SETUFNENTRY)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS CHECK MACRO [ARGS (COND
[(AND (BOUNDP (QUOTE CHECK))
CHECK)
(CONS (QUOTE PROGN)
(for I in ARGS collect
(LIST (QUOTE OR)
I
(LIST (QUOTE RAID)
(KWOTE (LIST (QUOTE Check-failure:)
I]
(T (CONS COMMENTFLG ARGS])
(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
(\PUTBASE N 0 0)
(\PUTBASE N 1 0)))
(PUTPROPS \StatsAdd1 BYTEMACRO [OPENLAMBDA (A)
(PROG NIL
(\PUTBASE
A 1
([LAMBDA (J)
(DECLARE (LOCALVARS . T))
(COND
((EQ J MAX.SMALL.INTEGER)
[\PUTBASE
A 0
(COND ((EQ (\GETBASE A 0)
MAX.POS.HINUM)
0)
(T (ADD1 (\GETBASE A 0]
0)
(T (ADD1 J]
(\GETBASE A 1])
(PUTPROPS SMALLPOSP MACRO ((X)
(EQ (\HILOC X)
(CONSTANT \SmallPosHi))))
(PUTPROPS SETXVAR MACRO [X (COND
((EQ (CAAR X)
(QUOTE QUOTE))
(LIST (QUOTE SETQ)
(CADAR X)
(CADR X)))
((LITATOM (CAR X))
(LIST (QUOTE SET)
(CAR X)
(CADR X)))
(T (HELP (CONS X (QUOTE (bad SETXVAR form])
(PUTPROPS SETXVAR ALTOMACRO (X (OR (AND (EQ (CAAR X)
(QUOTE QUOTE))
(LITATOM (CADAR X)))
(SHOULDNT))
(GLOBALVARS \VALSPACE)
(LIST (QUOTE SETQ.NOREF)
(CADAR X)
(CADR X))))
(PUTPROPS SETQ.NOREF DMACRO ((VAR VALUE)
(\PUTBASEPTR \VALSPACE (LLSH (\ATOMVALINDEX (QUOTE VAR))
1)
VALUE)))
(PUTPROPS IEQ MACRO ((X Y)
(IEQP X Y)))
(PUTPROPS IEQ ALTOMACRO (= . EQ))
(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 400Q)
(CONSTANTS WordsPerPage)
)
(* END EXPORTED DEFINITIONS)
)
(* atoms)
(DEFINEQ
(GETTOPVAL
[LAMBDA (X) (* bvm: " 2-AUG-83 13:00")
(PROG NIL
(COND
([NOT (LITATOM (OR X (RETURN]
(LISPERROR "ARG NOT LITATOM" X))
(T (RETURN (fetch (LITATOM VALUE) of X])
(SETTOPVAL
[LAMBDA (ATM VAL) (* bvm: " 2-AUG-83 13:00")
(COND
((NOT (LITATOM ATM))
(LISPERROR "ARG NOT LITATOM" ATM))
(T (SELECTQ ATM
(NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(T (OR (EQ VAL T)
(LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
(replace (LITATOM VALUE) of ATM with (UNLESSRDSYS VAL (\COPY VAL])
(FSETVAL
[LAMBDA (ATM VAL) (* lmm "18-MAR-82 15:40")
(* SETTOPVAL WITHOUT ERROR CHECKS FOR MAKEINIT ONLY)
(replace (LITATOM VALUE) of ATM with VAL])
(\SETGLOBALVAL.UFN
[LAMBDA (V A) (* lmm " 3-NOV-81 14:48")
(replace (VALINDEX VALUE) of A with V])
(\SETFVAR.UFN
[LAMBDA (V VCELL) (* lmm " 2-NOV-81 22:46")
(replace (VCELL VALUE) of VCELL with V])
(GETPROPLIST
[LAMBDA (ATM) (* lmm "13-FEB-83 13:25")
(PROG NIL
(RETURN (\GETBASEPTR \PLISTSPACE (LLSH (OR (\ATOMPROPINDEX ATM)
(RETURN))
1])
(SETPROPLIST
[LAMBDA (ATM LST) (* lmm " 9-NOV-81 14:22")
(replace (LITATOM PROPLIST) of ATM with LST])
)
(DEFINEQ
(\MKATOM
[LAMBDA (BASE OFFST LEN) (* lmm "13-FEB-83 13:32")
(PROG ((L 1)
(H 0)
H1 P Q C)
(COND
((ZEROP LEN)
(GO LP)))
(SETQ C (UNLESSRDSYS (\GETBASEBYTE BASE OFFST)
(NTHCHARCODE BASE OFFST)))
[PROGN [UNLESSRDSYS (COND
((AND (IGREATERP 2 LEN)
\OneCharAtomBase)
(RETURN (COND
((IGREATERP C 57)
(\ADDBASE \OneCharAtomBase (IDIFFERENCE C 10)))
((IGREATERP C 47)
(IDIFFERENCE C 48))
(T (\ADDBASE \OneCharAtomBase C]
(UNLESSRDSYS (COND
((AND (ILEQ C (CONSTANT (CHCON1 "9")))
(SETQ P (MKNUMATOM BASE OFFST LEN)))
(* MKNUMATOM returns a number or NIL)
(RETURN P]
(* Calculate first probe)
(SETQ H C)
HASH(COND
((NEQ L LEN)
(SETQ H (LOGAND [IPLUS (IPLUS (LOGAND (SETQ H1 (IPLUS H (LLSH (LOGAND H 4095)
2)))
\AtomHTmask)
(LLSH (LOGAND H1 127)
8))
(UNLESSRDSYS (\GETBASEBYTE BASE (IPLUS OFFST L))
(NTHCHARCODE BASE (IPLUS OFFST L]
\AtomHTmask))
(SETQ L (ADD1 L))
(GO HASH))) (* Lookup and compare)
LP [COND
((NEQ (SETQ P (\GETBASE \AtomHashTable H))
0)
(COND
((UNLESSRDSYS (AND (EQ [fetch (LITATOM PNAMELENGTH) of (SETQ Q (\ADDBASE
\ATOMSPACE
(SUB1 P]
LEN)
(\EQBYTES (fetch (LITATOM PNAMEBASE) of Q)
1 BASE OFFST LEN))
(EQ (\INDEXATOMPNAME (SETQ Q (SUB1 P)))
BASE))
(RETURN Q))
(T (SETQ H (LOGAND (IPLUS H \HashInc)
\AtomHTmask))
(GO LP] (* Not found, must make new atom)
(RETURN (NewAtom BASE OFFST LEN H])
(NewAtom
[LAMBDA (BASE BN LEN H) (* lmm " 2-JAN-82 14:31")
(PROG (ATM PB CPP PNP)
(RETURN (UNINTERRUPTABLY
(SETQ ATM \AtomFrLst)
(SETQ PB \NxtPnByte)
[COND
((NOT (ZEROP (LOGAND PB 1)))
(COND
([ZEROP (SETQ PB (LOGAND (ADD1 PB)
(SUB1 \CharsPerPnPage]
(\GCPNAMES))
(T (SETQ.NOREF \NxtPnByte PB]
(SETQ CPP \CurPnPage)
(* PNAME will start on this page)
(COND
((ILESSP (IDIFFERENCE \CharsPerPnPage PB)
(ADD1 LEN))
(\GCPNAMES)))
[COND
((EVENP ATM 1000Q)
(PROG ((PN (FOLDLO ATM WORDSPERPAGE)))
(COND
((IGREATERP PN \LastAtomPage)
(* Out of atom space)
(RAID "No more atoms left")))
(* Make entry in MDS type table)
(\MAKEMDSENTRY PN (LOGOR \TT.NOREF \LITATOM))
(* Make Def'n, TopVal, and Plist pages exist, and initialize)
(\INITATOMPAGE PN]
[\PUTBASEPTR (\ADDBASE \PNPSPACE (LLSH ATM 1))
0
(SETQ PNP (\VAG2 (IPLUS \PnCharsFblock (LRSH CPP 10Q))
(IPLUS (LLSH (LOGAND CPP 377Q)
10Q)
(LRSH PB 1]
(* PNAME starts on byte 1 always -
byte 0 is the length)
(\MOVEBYTES BASE BN PNP 1 LEN)
(\PUTBASEBYTE PNP 0 LEN)
(SETQ.NOREF \AtomFrLst (\PUTBASE \AtomHashTable H (ADD1 ATM)))
(COND
([ZEROP (SETQ.NOREF \NxtPnByte (LOGAND (IPLUS PB (LOGAND (IPLUS LEN 2)
177776Q))
(SUB1 \CharsPerPnPage]
(\GCPNAMES)))
(\ADDBASE \ATOMSPACE ATM))])
(\INITATOMPAGE
[LAMBDA (PN) (* lmm " 9-NOV-81 21:20")
(PROG ((OFFSET (UNFOLD PN (ITIMES WORDSPERCELL WORDSPERPAGE)))
J DEFBASE VALBASE) (* PN is in "words" of atom space. OFFSET is offset in words of definition, etc.
space which are in cells)
(* ASSUMES CCODEP BIT IN DEFINITION CELL IS DEFAULT "OFF")
(\NEW4PAGE (\ADDBASE \PNPSPACE OFFSET))
(\NEW4PAGE (SETQ DEFBASE (\ADDBASE \DEFSPACE OFFSET)))
(\NEW4PAGE (\ADDBASE \PLISTSPACE OFFSET))
(\NEW4PAGE (SETQ VALBASE (\ADDBASE \VALSPACE OFFSET)))
(for I from 0 to (SUB1 (ITIMES WORDSPERPAGE 4)) by WORDSPERCELL
do (\PUTBASEPTR VALBASE I (EVQ (QUOTE NOBIND])
(\GCPNAMES
[LAMBDA NIL (* rmk: "23-OCT-82 14:25")
(PROG ((VP (ADD1 \CurPnPage)))
(COND
((IGREATERP VP \LastPnPage)
(RAID "Out of atom p-name space")))
(\NEWPAGE (\VAG2 (IPLUS \PnCharsFblock (LRSH VP 8))
(LLSH (LOGAND VP 255)
8)))
(SETQ.NOREF \NxtPnByte 0)
(SETQ.NOREF \CurPnPage VP])
)
(DEFINEQ
(MAPATOMS
[LAMBDA (FN)
(DECLARE (LOCALVARS . T)) (* lmm "13-FEB-83 13:33")
(PROG ((A 0))
LP (APPLY* FN (\INDEXATOMPNAME A))
(COND
((EQ (SETQ A (ADD1 A))
\AtomFrLst)
(RETURN)))
(GO LP])
)
(DEFINEQ
(INITATOMS
[LAMBDA NIL (* lmm "13-FEB-83 13:27")
(* E (RADIX 10Q))
(* called only under MAKEINIT to initialize the making of atoms)
(PROG (BASE OFFST)
(CREATEPAGES \PNCHARSSPACE 1)
(CREATEPAGES \AtomHashTable \AtomHTpages)
(SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT))
(SETQ BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(SETQ OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING))
(COPYATOM NIL)
(COPYATOM (QUOTE NOBIND))
(for C from 0 to 377Q when (OR (ILESSP C 60Q)
(IGEQ C 72Q))
do (\PUTBASEBYTE BASE OFFST C)
(\MKATOM BASE OFFST 1))
(SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2))
(COPYATOM (FUNCTION \EVALFORM))
(* atom 370Q)
(COPYATOM (FUNCTION \GC.HANDLEOVERFLOW))
(* atom 371Q)
(COPYATOM (FUNCTION \DTESTFAIL))
(* atom 372Q)
(COPYATOM (FUNCTION \OVERFLOWMAKENUMBER))
(* atom 373Q)
(COPYATOM (FUNCTION \MAKENUMBER))
(* atom 374Q)
(COPYATOM (FUNCTION \SETGLOBAL.UFN))
(* atom 375Q)
(COPYATOM (FUNCTION \SETFVAR.UFN))
(* atom 376Q)
(COPYATOM (FUNCTION \GCMAPTABLE))
(* atom 377Q)
(COPYATOM (FUNCTION \INTERPRETER))
(* atom 400Q)
(OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER))
400Q)
(HELP (FUNCTION \INTERPRETER)
" not atom 400Q"))
(COPYATOM (FUNCTION MAKEFLOATNUMBER))
(* atom 401q)
])
(COPYATOM
[LAMBDA (X) (* lmm "13-FEB-83 13:27")
(* this function is only for the use of MAKEINIT, which passes it a real atom to be translated into an atom in the
remote sysout -
\SCRATCHSTRING is initialized in INITATOMS)
(PROG ((N (LOCAL (NCHARS X)))
(BASE (ffetch (STRINGP BASE) of \SCRATCHSTRING))
(OFFST (ffetch (STRINGP OFFST) of \SCRATCHSTRING)))
[for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
(LOCAL (NTHCHARCODE X I]
(RETURN (\ATOMDEFINDEX (\MKATOM BASE OFFST N])
(UNCOPYATOM
[LAMBDA (N) (* rmk: "23-OCT-82 14:27")
(* this is used only by RDSYS to turn atom numbers into
names)
(COND
((AND \AtomFrLst (IGEQ N \AtomFrLst))
(CONCAT "ATOM#" N))
(T (PROG [(ADDR (\GETBASEPTR \PNPSPACE (LLSH N 1)))
LEN
(STR (OR COPYATOMSTR (SETQ COPYATOMSTR (LOCAL (ALLOCSTRING \PNAMELIMIT]
(SETQ LEN (\GETBASEBYTE ADDR 0))
[for I from 1 to LEN do (LOCAL (RPLSTRING COPYATOMSTR I (FCHARACTER (\GETBASEBYTE
ADDR I]
(RETURN (LOCAL (SUBATOM COPYATOMSTR 1 LEN])
)
(RPAQQ \PNAMELIMIT 177Q)
(DEFINEQ
(DEFINEDP
[LAMBDA (A) (* lmm "28-JUL-81 15:47")
(AND (LITATOM A)
(fetch (LITATOM DEFPOINTER) of A])
(PUTD
[LAMBDA (FN DEF FLG) (* lmm "13-OCT-82 09:47")
(SETQ FN (\DTEST FN (QUOTE LITATOM)))
(PROG1 DEF [COND
((AND (NULL FLG)
(ARRAYP DEF)
(EQ (fetch (ARRAYP TYP) of DEF)
\ST.CODE)
(NEQ (fetch (CODEARRAY FRAMENAME) of DEF)
FN))
(SETQ DEF (\RENAMEDFN DEF FN]
(\PUTD FN DEF])
(\PUTD
[LAMBDA (FN DEF) (* edited: "19-FEB-82 16:25")
(UNINTERRUPTABLY
(PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))
(DVAL DEF))
(COND
((AND (ARRAYP DVAL)
(EQ (fetch (ARRAYP TYP) of DVAL)
\ST.CODE))
(SETQ DVAL (fetch (ARRAYP BASE) of DVAL))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL))
((LISTP DVAL)
(SETQ DVAL (OR (AND COMPILEATPUTDFLG (\MAKEPSEUDOCODE DVAL FN))
(GO EXPR)))
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with T)
(GO CODE))
(T (GO EXPR)))
CODE(replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL)
(replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (FNHEADER ARGTYPE) of DVAL))
(replace (DEFINITIONCELL FASTP) of DCELL with (ZEROP (fetch (FNHEADER NTSIZE)
of DVAL)))
(replace (DEFINITIONCELL CCODEP) of DCELL with T)
(RETURN DEF)
EXPR(replace CCODEP of DCELL with NIL)
(replace DEFPOINTER of DCELL with DVAL)
(RETURN DEF)))])
(GETD
[LAMBDA (A) (* rmk: "10-DEC-82 10:51")
(COND
((LITATOM A)
(SETQ A (fetch (LITATOM DEFINITIONCELL) of A))
(COND
[(fetch (DEFINITIONCELL CCODEP) of A)
(COND
((fetch (DEFINITIONCELL PSEUDOCODEP) of A)
(\PSEUDOCODE.REALDEF (fetch (DEFINITIONCELL DEFPOINTER) of A)))
(T (SETQ A (fetch (DEFINITIONCELL DEFPOINTER) of A))
(create ARRAYP
BASE ← A
LENGTH ←(UNFOLD (\#BLOCKDATACELLS A)
BYTESPERCELL)
TYP ← \ST.CODE]
(T (fetch (DEFINITIONCELL DEFPOINTER) of A])
(PUTDEFN
[LAMBDA (FN CA SIZE) (* rmk: "23-OCT-82 14:32")
(PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))
[BLOCKINFO (PROGN
(* Reserve enough space. FILECODEBLOCK leaves file pointing at first data word, so BASE is set to that below.
BLOCKINFO is used for setting block trailer.)
(FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL)
(fetch (CODEARRAY ALIGNED) of CA]
(BASE (FILEARRAYBASE)))
(replace (DEFINITIONCELL DEFPOINTER) of DCELL with BASE)
(replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (CODEARRAY ARGTYPE) of CA))
(replace (DEFINITIONCELL FASTP) of DCELL with (ZEROP (fetch (CODEARRAY NTSIZE)
of CA)))
(replace (DEFINITIONCELL CCODEP) of DCELL with T)
(replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)
[COND
((FMEMB FN LOCKEDFNS)
(\LOCKCELL DCELL 1)
(\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE)
(FOLDHI SIZE BYTESPERWORD))
WORDSPERPAGE]
[COND
((EQ FN (LOCAL (FUNCTION \RESETSTACK)))
(SETQ RESETPTR (FILEARRAYBASE))
(SETQ RESETPC (fetch (CODEARRAY STARTPC) of CA]
(AOUT CA 0 SIZE OUTX (QUOTE CODE))
(BOUTZEROS (MODUP SIZE BYTESPERCELL))
(FILEBLOCKTRAILER BLOCKINFO])
(GETDEFN
[LAMBDA (A) (* lmm "20-AUG-81 12:17")
(fetch (LITATOM DEFPOINTER) of A])
)
(RPAQQ COMPILEATPUTDFLG NIL)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS LITATOM ((PNPCELL (\ADDBASE \PNPSPACE (LLSH (\ATOMPROPINDEX DATUM)
1)))
(DEFINITIONCELL (\ADDBASE \DEFSPACE (LLSH (\ATOMDEFINDEX DATUM)
1)))
(PROPCELL (\ADDBASE \PLISTSPACE (LLSH (\ATOMPROPINDEX DATUM)
1)))
(VALINDEX (\ATOMVALINDEX DATUM)))
(TYPE? (LITATOM DATUM))
[BLOCKRECORD PNPCELL ((PNAMEBASE FULLXPOINTER))
(BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE]
(BLOCKRECORD PROPCELL ((PROPLIST POINTER))))
(BLOCKRECORD VCELL ((VALUE FULLPOINTER)))
(ACCESSFNS VALINDEX [(VCELL (\ADDBASE \VALSPACE (LLSH DATUM 1])
]
[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 10Q))
(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)
14Q 40Q)))
(NPVARWORDS (UNFOLD (ADD1 (fetch (FNHEADER PV) of DATUM))
WORDSPERQUAD))
(FRAMENAME (fetch (FNHEADER #FRAMENAME) of DATUM)
(UNINTERRUPTABLY
(CHECK (NEQ (\HILOC DATUM)
\STACKHI))
(\DELREF (fetch (FNHEADER #FRAMENAME) of DATUM))
(\ADDREF NEWVALUE)
(replace (FNHEADER #FRAMENAME) of DATUM with NEWVALUE))])
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \ATOMVALINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMDEFINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMPNAMEINDEX DMACRO (= . \LOLOC))
(PUTPROPS \ATOMPROPINDEX DMACRO (= . \LOLOC))
(PUTPROPS \INDEXATOMPNAME DMACRO ((X)
(\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMVAL DMACRO ((X)
(\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMDEF DMACRO ((X)
(\VAG2 \AtomHI X)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \SCRATCHSTRING
COMPILEATPUTDFLG)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \LastAtomPage 177Q)
(RPAQQ \PNAMELIMIT 177Q)
(RPAQQ \CharsPerPnPage 1000Q)
(RPAQQ \AtomHTmask 77777Q)
(RPAQQ \PnCharsFblock 30Q)
(CONSTANTS (\LastAtomPage 177Q)
\PNAMELIMIT
(\CharsPerPnPage 1000Q)
(\AtomHTmask 77777Q)
(\PnCharsFblock 30Q))
)
(* END EXPORTED DEFINITIONS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \EQBYTES MACRO [LAMBDA (BASE1 BN1 BASE2 BN2 LEN)
(PROG NIL
LP (COND
((ZEROP LEN)
(RETURN T))
((NEQ (\GETBASEBYTE BASE1 BN1)
(\GETBASEBYTE BASE2 BN2))
(RETURN))
(T (add BN1 1)
(add BN2 1)
(add LEN -1)
(GO LP])
)
(ADDTOVAR DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL)
)
(* for executing boot expressions when first run)
(DEFINEQ
(\RESETSYSTEMSTATE
[LAMBDA NIL (* rmk: " 5-JUN-81 17:32")
(\KEYBOARDON T)
(\RESETTERMINAL])
(INITIALEVALQT
[LAMBDA NIL (* bvm: "21-APR-83 12:02")
(DECLARE (GLOBALVARS BOOTFILES))
(\SETIOPOINTERS)
(PROG ((RL BOOTFILES)
FL L)
(OR RL (RETURN))
(SIMPLEPRINT "evaluating initial expressions:
") (* BOOTFILES is the list of boot files in reverse order)
R (SETQ FL (CONS (CAR RL)
FL))
(COND
((SETQ RL (CDR RL))
(GO R)))
L1 [COND
([LISTP (SETQ L (GETTOPVAL (CAR FL]
(SIMPLEPRINT (CAR FL)) (* Print the name of the bootfile)
(DSPBOUT (CHARCODE CR))
(PROG NIL
L2 [EVAL (PROG1 (CAR L)
(SETTOPVAL (CAR FL)
(SETQ L (CDR L]
(AND (LISTP L)
(GO L2)))
(SETTOPVAL (CAR FL)
(QUOTE NOBIND]
(COND
((SETQ FL (CDR FL))
(GO L1)))
(SETQ BOOTFILES NIL)
(INTERPRET.REM.CM) (* See if command line has anything to say)
) (* Value is T so that correct value is returned when
this is called from within COPYSYS0)
T])
(SIMPLEPRINT
[LAMBDA (X N) (* lmm "17-MAY-80 20:19")
(COND
[(OR (LITATOM X)
(STRINGP X))
(for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I]
((LISTP X)
(COND
((ZEROP N)
(SIMPLEPRINT "&"))
(T (DSPBOUT (CHARCODE %())
(PROG NIL
LP [SIMPLEPRINT (CAR X)
(SETQ N (COND
((SMALLPOSP N)
(SUB1 N))
(T 3]
(COND
((ZEROP N)
(SIMPLEPRINT " --)"))
((NULL (SETQ X (CDR X)))
(SIMPLEPRINT ")"))
((NLISTP X)
(SIMPLEPRINT " . ")
(SIMPLEPRINT X)
(SIMPLEPRINT ")"))
(T (SIMPLEPRINT " ")
(GO LP])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS RESETFORMS BOOTFILES)
)
(* date/time, stats)
(DEFINEQ
(CLOCK
[LAMBDA (N BOX) (* lmm "15-OCT-82 11:44")
(SELECTQ (OR N 0)
[0 (* time of day in MS)
(\CLOCK0 (COND
((type? FIXP BOX)
BOX)
(T (CREATECELL \FIXP]
(1 (* time this VM was started)
(fetch STARTTIME of \MISCSTATS))
[2 (* run time for this VM)
(\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE
(\BOXIDIFFERENCE [\CLOCK0 (COND
((type? FIXP BOX)
BOX)
(T (CREATECELL \FIXP]
(LOCF (fetch SWAPWAITTIME
of \MISCSTATS)))
(LOCF (fetch KEYBOARDWAITTIME of \MISCSTATS)))
(LOCF (fetch STARTTIME of \MISCSTATS)))
(LOCF (fetch GCTIME of \MISCSTATS]
(3 (* GC TIME)
(fetch GCTIME of \MISCSTATS))
(\ILLEGAL.ARG N])
(CLOCKDIFFERENCE
[LAMBDA (OLDCLOCK) (* bvm: "21-JUL-83 16:56")
(* * Returns number of msecs that have elapsed since the time given by OLDCLOCK, a value of CLOCK 0;
use this to avoid number boxing in timing loops)
(GLOBALRESOURCE (\CLOCKDIFBOX)
(PROG ((NOW (CLOCK0 \CLOCKDIFBOX)))
(RETURN (\BOXIDIFFERENCE NOW OLDCLOCK])
(\CLOCKGREATERP
[LAMBDA (OLDCLOCK MSECS) (* bvm: "21-JUL-83 16:56")
(* * True if more than MSECS milliseconds have elapsed since OLDCLOCK was set)
(GLOBALRESOURCE (\CLOCKDIFBOX)
(PROG ((NOW (CLOCK0 \CLOCKDIFBOX)))
(RETURN (IGREATERP (\BOXIDIFFERENCE NOW OLDCLOCK)
MSECS])
(\SECONDSCLOCKGREATERP
[LAMBDA (OLDCLOCK SECONDS) (* bvm: "21-JUL-83 16:56")
(* * True if more than SECONDS seconds have elapsed since OLDCLOCK was set)
(GLOBALRESOURCE (\CLOCKDIFBOX)
(PROG ((NOW (\DAYTIME0 \CLOCKDIFBOX)))
(RETURN (IGREATERP (\BOXIDIFFERENCE NOW OLDCLOCK)
SECONDS])
(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])
(DISMISS
[LAMBDA (N) (* bvm: " 2-JUN-81 17:03")
(GLOBALRESOURCE (\DISMISSBOX)
(PROG ((NOW (CLOCK0 \DISMISSBOX))
(N-100 (IDIFFERENCE N 100))
ELAPSED)
LP (COND
((IGREATERP (SETQ ELAPSED (CLOCKDIFFERENCE NOW))
N)
(RETURN N))
((ILESSP ELAPSED N-100) (* only run background task if at least 100 msecs left)
(\BACKGROUND)))
(GO LP)))])
(PAGEFAULTS
[LAMBDA NIL (* rrb "13-NOV-80 15:36")
(DECLARE (GLOBALVARS \MISCSTATS))
(fetch PAGEFAULTS of \MISCSTATS])
(\SETTOTALTIME
[LAMBDA NIL (* lmm "11-DEC-80 15:14")
(* updates the total time field of the misc stats page.)
(replace TOTALTIME of \MISCSTATS with (IPLUS (fetch TOTALTIME of \MISCSTATS)
(IDIFFERENCE (CLOCK 0)
(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 -20000000000Q)))
(PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE)
(LOGXOR DATE -20000000000Q)))
(* END EXPORTED DEFINITIONS)
)
(RPAQQ \CLOCKDIFBOX NIL)
(RPAQQ \DISMISSBOX NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \CLOCKDIFBOX \DISMISSBOX)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \CLOCKDIFBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (CREATECELL \FIXP)))
(PUTDEF (QUOTE \DISMISSBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (CREATECELL \FIXP)))
)
(* Fast functions for moving and clearing storage, using BitBlt)
(DEFINEQ
(\INITSTORAGEBBTS
[LAMBDA (FLG) (* bvm: "15-JUN-82 13:59")
(COND
((OR FLG (NOT WINDFLG)) (* Don't do this with Pilot bitblt yet)
(SETQ \MOVESTORAGEBBT (\CREATESTORAGEBBT 0))
(SETQ \CLEARSTORAGEBBT (\CREATESTORAGEBBT 12))
(PUTD (QUOTE \MOVEBYTES)
(GETD (QUOTE \LONGMOVEBYTES))
T)
(PUTD (QUOTE \ZEROWORDS)
(GETD (QUOTE \LONGZEROWORDS))
T)
(PUTD (QUOTE \BLT)
(GETD (QUOTE \LONGWORDBLT))
T)
(PUTD (QUOTE \ZEROBYTES)
(GETD (QUOTE \LONGZEROBYTES))
T])
(\CREATESTORAGEBBT
[LAMBDA (FUNCTION) (* bvm: " 7-APR-81 12:12")
(* create a BitBltTable for manipulating storage. It defaults fields to set up a single raster source and
destination with a texture of all zeros. FUNCTION is the bitblt function to use (numeric code))
(create BitBltTable
BBTFunction ←(LOGOR FUNCTION 32768)
BBTDTY ← 0
BBTDBMR ← 8192
BBTDH ← 1
BBTSBMR ← 8192
BBTSTY ← 0
BBTGray0 ← 0
BBTGray1 ← 0
BBTGray2 ← 0
BBTGray3 ← 0])
(\CLEARSTORAGE
[LAMBDA (BASE OFFSET NBITS) (* lmm " 9-NOV-81 21:22")
(* clears NBITS of storage with a call to BITBLT Assumes that NBITS is less than 2↑16 and that all of the bits are
on the same page.)
(DECLARE (GLOBALVARS \CLEARSTORAGEBBT))
(UNINTERRUPTABLY
(replace BBTDLX of \CLEARSTORAGEBBT with OFFSET)
(replace BBTDW of \CLEARSTORAGEBBT with NBITS)
(replace BBTDHiloc of \CLEARSTORAGEBBT with (\HILOC BASE))
(replace BBTDLoloc of \CLEARSTORAGEBBT with (\LOLOC BASE))
(\BITBLT1 \CLEARSTORAGEBBT))])
(\MOVESTORAGE
[LAMBDA (SBASE SBITOFFSET DBASE DBITOFFSET NBITS)
(* lmm " 9-NOV-81 21:22")
(* Moves bits from source to destination for NBITS.
Assumes NBITS is less than 2↑16 and that no segment boundaries are crossed)
(UNINTERRUPTABLY
(replace BBTDLX of \MOVESTORAGEBBT with DBITOFFSET)
(replace BBTSLX of \MOVESTORAGEBBT with SBITOFFSET)
(replace BBTDW of \MOVESTORAGEBBT with NBITS)
(replace BBTDHiloc of \MOVESTORAGEBBT with (\HILOC DBASE))
(replace BBTDLoloc of \MOVESTORAGEBBT with (\LOLOC DBASE))
(replace BBTSHiloc of \MOVESTORAGEBBT with (\HILOC SBASE))
(replace BBTSLoloc of \MOVESTORAGEBBT with (\LOLOC SBASE))
(\BITBLT1 \MOVESTORAGEBBT))])
(\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])
(\LONGMOVEBYTES
[LAMBDA (SBASE SBN DBASE DBN NBYTES)
(* lmm " 9-NOV-81 21:19")
(PROG (SBASE.END DBASE.END BYTESTOMOVE TOTALBYTESMOVED)
(COND
((ILESSP NBYTES \BITBLT.CUTOFF)
(* Cheaper to do it the simple way)
[FRPTQ NBYTES (\PUTBASEBYTE DBASE (PROG1 DBN (add DBN 1))
(\GETBASEBYTE SBASE (PROG1 SBN (add SBN 1]
(RETURN NIL)))
[COND
((IGREATERP SBN 1)
(SETQ SBASE (\ADDBASE SBASE (LRSH SBN 1)))
(SETQ SBN (LOGAND SBN 1]
[COND
((IGREATERP DBN 1)
(SETQ DBASE (\ADDBASE DBASE (LRSH DBN 1)))
(SETQ DBN (LOGAND DBN 1]
(SETQ SBASE.END (\ADDBASE SBASE (LRSH (IPLUS NBYTES SBN -1)
1)))
(SETQ DBASE.END (\ADDBASE DBASE (LRSH (IPLUS NBYTES DBN -1)
1)))
SEGLP
[SETQ BYTESTOMOVE (COND
[(EQ (fetch SEGMENT# of SBASE)
(fetch SEGMENT# of SBASE.END))
(* Source all in one segment)
(COND
((EQ (fetch SEGMENT# of DBASE)
(fetch SEGMENT# of DBASE.END))
(* Destination all in one segment)
NBYTES)
(T (* destination overlaps segment, move as much as we can)
(IDIFFERENCE (BYTES.LEFT.IN.SEGMENT DBASE)
DBN]
((OR (EQ (fetch SEGMENT# of DBASE)
(fetch SEGMENT# of DBASE.END))
(IGREATERP (fetch WORDINSEGMENT of SBASE)
(fetch WORDINSEGMENT of DBASE)))
(* Destination all in one segment, but source not, or both overlap segments, with
more space in destination -- move according to source constraint)
(IDIFFERENCE (BYTES.LEFT.IN.SEGMENT SBASE)
SBN))
(T (* more space in source)
(IDIFFERENCE (BYTES.LEFT.IN.SEGMENT DBASE)
DBN]
(SETQ TOTALBYTESMOVED BYTESTOMOVE)
[PROG ((SBITNUM (BYTES.TO.BITS SBN))
(DBITNUM (BYTES.TO.BITS DBN)))
(* convert to bit offsets)
BLTLP
(COND
((ILEQ BYTESTOMOVE (CONSTANT (WORDS.TO.BYTES MAXWORDBLT)))
(\MOVESTORAGE SBASE SBITNUM DBASE DBITNUM (BYTES.TO.BITS BYTESTOMOVE)))
(T (* move 2↑11-1 words and try again)
(\MOVESTORAGE SBASE SBITNUM DBASE DBITNUM (CONSTANT (WORDS.TO.BITS MAXWORDBLT)))
(SETQ SBASE (\ADDBASE SBASE MAXWORDBLT))
(SETQ DBASE (\ADDBASE DBASE MAXWORDBLT))
[SETQ BYTESTOMOVE (IDIFFERENCE BYTESTOMOVE (CONSTANT (WORDS.TO.BYTES MAXWORDBLT]
(GO BLTLP]
(COND
((ZEROP (SETQ NBYTES (IDIFFERENCE NBYTES TOTALBYTESMOVED)))
(RETURN)))
(SETQ SBASE (\ADDBASE SBASE (LRSH (IPLUS BYTESTOMOVE SBN)
1)))
(SETQ SBN (LOGXOR SBN (LOGAND BYTESTOMOVE 1)))
(SETQ DBASE (\ADDBASE DBASE (LRSH (IPLUS BYTESTOMOVE DBN)
1)))
(SETQ DBN (LOGXOR DBN (LOGAND BYTESTOMOVE 1)))
(GO SEGLP])
(\BLT
[LAMBDA (DBASE SBASE NWORDS) (* bvm: "15-JUN-82 13:52")
(* redefined by \LONGWORDBLT)
(from 1 to NWORDS do (\PUTBASE DBASE 0 (\GETBASE SBASE 0))
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ SBASE (\ADDBASE SBASE 1])
(\LONGWORDBLT
[LAMBDA (DBASE SBASE NWORDS) (* bvm: "15-JUN-82 13:54")
(* * Move NWORDS words from SBASE to DBASE as fast as we can manage. Redefines \BLT after bootstrap)
(COND
[(ILESSP NWORDS \BITBLT.CUTOFF) (* Cheaper the easy way)
(for I from 1 to NWORDS do (\PUTBASE DBASE 0 (\GETBASE SBASE 0))
(SETQ DBASE (\ADDBASE DBASE 1))
(SETQ SBASE (\ADDBASE SBASE 1]
(T (PROG (SBASE.END DBASE.END WORDSTOMOVE TOTALWORDSMOVED)
(SETQ SBASE.END (\ADDBASE SBASE (SUB1 NWORDS)))
(SETQ DBASE.END (\ADDBASE DBASE (SUB1 NWORDS)))
SEGLP
[SETQ WORDSTOMOVE (COND
[(EQ (fetch SEGMENT# of SBASE)
(fetch SEGMENT# of SBASE.END)) (* Source all in one segment)
(COND
((EQ (fetch SEGMENT# of DBASE)
(fetch SEGMENT# of DBASE.END)) (* Destination all in one segment)
NWORDS)
(T (WORDS.LEFT.IN.SEGMENT DBASE]
((OR (EQ (fetch SEGMENT# of DBASE)
(fetch SEGMENT# of DBASE.END))
(IGREATERP (fetch WORDINSEGMENT of SBASE)
(fetch WORDINSEGMENT of DBASE)))
(* Destination all in one segment, but source not, or
both overlap segments, with more space in destination)
(WORDS.LEFT.IN.SEGMENT SBASE))
(T (* more space in source)
(WORDS.LEFT.IN.SEGMENT DBASE]
(SETQ TOTALWORDSMOVED WORDSTOMOVE)
BLTLP
(COND
((IGREATERP WORDSTOMOVE MAXWORDBLT) (* move 2↑11-1 words and try again)
(\MOVESTORAGE SBASE 0 DBASE 0 (CONSTANT (WORDS.TO.BITS MAXWORDBLT)))
(SETQ SBASE (\ADDBASE SBASE MAXWORDBLT))
(SETQ DBASE (\ADDBASE DBASE MAXWORDBLT))
(SETQ WORDSTOMOVE (IDIFFERENCE WORDSTOMOVE MAXWORDBLT))
(GO BLTLP))
(T (\MOVESTORAGE SBASE 0 DBASE 0 (WORDS.TO.BITS WORDSTOMOVE))
(COND
((NEQ (SETQ NWORDS (IDIFFERENCE NWORDS TOTALWORDSMOVED))
0)
(SETQ SBASE (\ADDBASE SBASE WORDSTOMOVE))
(SETQ DBASE (\ADDBASE DBASE WORDSTOMOVE))
(GO SEGLP])
(\ZEROWORDS
[LAMBDA (BASE ENDBASE) (* bvm: "27-NOV-82 17:23")
(* Bootstrapping version of \ZEROWORDS)
[COND
((NOT (PTRGTP BASE ENDBASE))
(COND
([AND (EVENP (\LOLOC BASE))
(NOT (EVENP (\LOLOC ENDBASE] (* Can transfer two words at a time)
(for (B ← BASE) by (\ADDBASE B 2) do (\PUTBASEPTR B 0 NIL)
repeatuntil (EQ (\ADDBASE B 1)
ENDBASE)))
(T (for (B ← BASE) by (\ADDBASE B 1) do (\PUTBASE B 0 0) repeatuntil (EQ B ENDBASE]
BASE])
(\LONGZEROWORDS
[LAMBDA (BASE ENDBASE) (* lmm " 9-NOV-81 21:20")
(* clears words from BASE thru ENDBASE in the fastest way possible)
(PROG (NWORDS)
SEGLP
(COND
((PTRGTP BASE ENDBASE)
(RETURN))) (* First, we can only blt within a segment, so check alignment)
[SETQ NWORDS (COND
[(EQ (fetch SEGMENT# of BASE)
(fetch SEGMENT# of ENDBASE))
(* all on one segment)
(ADD1 (IDIFFERENCE (fetch WORDINSEGMENT of ENDBASE)
(fetch WORDINSEGMENT of BASE]
(T (* different segment.)
(WORDS.LEFT.IN.SEGMENT BASE]
BLTLP (* now use bitblt to clear out NWORDS words.
Can only do 2↑16-1 bits at a time, so might take more than one pass)
[COND
((IGREATERP NWORDS MAXWORDBLT)
(\CLEARSTORAGE BASE 0 (CONSTANT (WORDS.TO.BITS MAXWORDBLT)))
(SETQ BASE (\ADDBASE BASE MAXWORDBLT))
(SETQ NWORDS (IDIFFERENCE NWORDS MAXWORDBLT))
(GO BLTLP))
(T (\CLEARSTORAGE BASE 0 (WORDS.TO.BITS NWORDS))
(SETQ BASE (\ADDBASE BASE NWORDS]
(GO SEGLP])
(\MOVEWORDS
[LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (* bvm: "15-JUN-82 13:56")
(\BLT (\ADDBASE DBASE DOFFSET)
(\ADDBASE SBASE SOFFSET)
NWORDS])
(\ZEROBYTES
[LAMBDA (BASE FIRST LAST) (* bvm: "24-MAY-82 21:46")
(* Redefined by \LONGZEROBYTES)
(FRPTQ (ADD1 (IDIFFERENCE LAST FIRST))
(PROGN (\PUTBASEBYTE BASE FIRST 0)
(add FIRST 1)))
NIL])
(\LONGZEROBYTES
[LAMBDA (BASE FIRST LAST) (* lmm " 9-NOV-81 21:20")
(* clears bytes from FIRST thru LAST in the fastest way
possible)
(PROG ((NBYTES (ADD1 (IDIFFERENCE LAST FIRST)))
ENDBASE SOMEBYTES)
(COND
((ILEQ NBYTES 0)
(RETURN)))
(SETQ ENDBASE (\ADDBASE BASE (LRSH LAST 1)))
[COND
((IGREATERP FIRST 1) (* Adjust BASE to be the correct first base)
(SETQ BASE (\ADDBASE BASE (LRSH FIRST 1)))
(SETQ FIRST (LOGAND FIRST 1]
SEGLP
[COND
((EQ (fetch SEGMENT# of BASE)
(fetch SEGMENT# of ENDBASE)) (* All in one segment, so do whole area at once)
(SETQ SOMEBYTES NBYTES)
(SETQ NBYTES 0))
(T (SETQ SOMEBYTES (IDIFFERENCE (BYTES.LEFT.IN.SEGMENT BASE)
FIRST))
(SETQ NBYTES (IDIFFERENCE NBYTES SOMEBYTES]
[PROG ((BITNUM (BYTES.TO.BITS FIRST))) (* convert to bit offset)
BLTLP
(COND
((ILEQ SOMEBYTES (CONSTANT (WORDS.TO.BYTES MAXWORDBLT)))
(\CLEARSTORAGE BASE BITNUM (BYTES.TO.BITS SOMEBYTES)))
(T (* clear 2↑11-1 words and try again)
(\CLEARSTORAGE BASE BITNUM (CONSTANT (WORDS.TO.BITS MAXWORDBLT)))
(SETQ BASE (\ADDBASE BASE MAXWORDBLT))
[SETQ SOMEBYTES (IDIFFERENCE SOMEBYTES (CONSTANT (WORDS.TO.BYTES MAXWORDBLT]
(GO BLTLP]
(COND
((ZEROP NBYTES)
(RETURN)))
(SETQ BASE (\VAG2 (ADD1 (fetch SEGMENT# of BASE))
0))
(SETQ FIRST 0)
(GO SEGLP])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MOVESTORAGEBBT \CLEARSTORAGEBBT)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(/DECLAREDATATYPE (QUOTE BitBltTable)
(QUOTE (WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD WORD WORD WORD WORD)))
(\INITSTORAGEBBTS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS WORDS.TO.BYTES MACRO ((N)
(LLSH N 1)))
(PUTPROPS WORDS.TO.BITS MACRO ((N)
(LLSH N 4)))
(PUTPROPS BYTES.TO.BITS MACRO ((N)
(LLSH N 3)))
(PUTPROPS BYTES.LEFT.IN.SEGMENT MACRO ((BASE)
(WORDS.TO.BYTES (WORDS.LEFT.IN.SEGMENT BASE))))
(PUTPROPS WORDS.LEFT.IN.SEGMENT MACRO [(BASE)
(ADD1 (IDIFFERENCE MaxSegWord (fetch WORDINSEGMENT
of BASE])
)
(DECLARE: EVAL@COMPILE
(RPAQQ MaxSegWord 177777Q)
(RPAQQ MAXWORDBLT 3777Q)
(RPAQQ \BITBLT.CUTOFF 10Q)
(CONSTANTS (MaxSegWord 177777Q)
(MAXWORDBLT 3777Q)
(\BITBLT.CUTOFF 10Q))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTCOPY
(* for MAKEINIT and READSYS)
(ADDTOVAR INITVALUES (\NxtPnByte 0)
(\CurPnPage 0)
(\NxtAtomPage 0)
(\AtomFrLst 0))
(ADDTOVAR INITPTRS (\OneCharAtomBase NIL)
(\SCRATCHSTRING))
(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN)
(FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES \MOVEBYTES)
(FNS COPYATOM INITATOMS)
(BLOCKS (\MKATOM \MKATOM NewAtom \MOVEBYTES (NOLINKFNS . T))))
(ADDTOVAR EXPANDMACROFNS SMALLPOSP \EQBYTES)
(ADDTOVAR MKI.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . I.ATOMNUMBER)
(\ATOMVALINDEX . I.ATOMNUMBER)
(\ATOMPROPINDEX . I.ATOMNUMBER)
(\ATOMPNAMEINDEX . I.ATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 400Q)
(SETTOPVAL . I.FSETVAL))
(ADDTOVAR RD.SUBFNS (MKNUMATOM . NILL)
(\ATOMDEFINDEX . VATOMNUMBER)
(\ATOMPROPINDEX . VATOMNUMBER)
(\ATOMVALINDEX . VATOMNUMBER)
(SETQ.NOREF . SETQ)
(\BITBLT.CUTOFF . 400Q)
(\INDEXATOMPNAME . VATOM)
(\INDEXATOMVAL . VATOM)
(\INDEXATOMDEF . VATOM)
(NewAtom . ERROR!))
(ADDTOVAR RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN)
(FNS LISTP)
(VARS (COPYATOMSTR)))
(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
(ADDTOVAR RDVALS (\AtomFrLst))
)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 3675Q 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (11205Q 16372Q (LISTP 11217Q . 11574Q) (LITATOM 11576Q . 12143Q) (FIXP 12145Q . 12556Q)
(STRINGP 12560Q . 13147Q) (SMALLP 13151Q . 13536Q) (SMALLPOSP 13540Q . 13721Q) (NLISTP 13723Q . 14242Q
) (ARRAYP 14244Q . 14631Q) (ATOM 14633Q . 15253Q) (FLOATP 15255Q . 15642Q) (NUMBERP 15644Q . 16134Q) (
STACKP 16136Q . 16370Q)) (16414Q 20332Q (INITUFNTABLE 16426Q . 17537Q) (SETUFNENTRY 17541Q . 20330Q))
(20333Q 20555Q (\UNKNOWN.UFN 20345Q . 20553Q)) (25402Q 30517Q (GETTOPVAL 25414Q . 26035Q) (SETTOPVAL
26037Q . 26707Q) (FSETVAL 26711Q . 27261Q) (\SETGLOBALVAL.UFN 27263Q . 27540Q) (\SETFVAR.UFN 27542Q .
27755Q) (GETPROPLIST 27757Q . 30270Q) (SETPROPLIST 30272Q . 30515Q)) (30520Q 42020Q (\MKATOM 30532Q .
34177Q) (NewAtom 34201Q . 37552Q) (\INITATOMPAGE 37554Q . 41166Q) (\GCPNAMES 41170Q . 42016Q)) (42021Q
42432Q (MAPATOMS 42033Q . 42430Q)) (42433Q 51105Q (INITATOMS 42445Q . 46420Q) (COPYATOM 46422Q .
47625Q) (UNCOPYATOM 47627Q . 51103Q)) (51144Q 61077Q (DEFINEDP 51156Q . 51406Q) (PUTD 51410Q . 52231Q)
(\PUTD 52233Q . 54526Q) (GETD 54530Q . 55720Q) (PUTDEFN 55722Q . 60641Q) (GETDEFN 60643Q . 61075Q)) (
70211Q 74425Q (\RESETSYSTEMSTATE 70223Q . 70425Q) (INITIALEVALQT 70427Q . 73022Q) (SIMPLEPRINT 73024Q
. 74423Q)) (74603Q 105032Q (CLOCK 74615Q . 76661Q) (CLOCKDIFFERENCE 76663Q . 77522Q) (\CLOCKGREATERP
77524Q . 100300Q) (\SECONDSCLOCKGREATERP 100302Q . 101067Q) (DAYTIME 101071Q . 101473Q) (
ALTO.TO.LISP.DATE 101475Q . 102275Q) (LISP.TO.ALTO.DATE 102277Q . 102517Q) (DISMISS 102521Q . 103436Q)
(PAGEFAULTS 103440Q . 103741Q) (\SETTOTALTIME 103743Q . 104605Q) (\SERIALNUMBER 104607Q . 105030Q)) (
106321Q 141025Q (\INITSTORAGEBBTS 106333Q . 107542Q) (\CREATESTORAGEBBT 107544Q . 110636Q) (
\CLEARSTORAGE 110640Q . 112010Q) (\MOVESTORAGE 112012Q . 113532Q) (\MOVEBYTES 113534Q . 115637Q) (
\LONGMOVEBYTES 115641Q . 123664Q) (\BLT 123666Q . 124415Q) (\LONGWORDBLT 124417Q . 130711Q) (
\ZEROWORDS 130713Q . 132110Q) (\LONGZEROWORDS 132112Q . 134470Q) (\MOVEWORDS 134472Q . 134764Q) (
\ZEROBYTES 134766Q . 135466Q) (\LONGZEROBYTES 135470Q . 141023Q)))))
STOP