(FILECREATED "13-Sep-84 15:12:43" {ERIS}<LISPCORE>SOURCES>LLBASIC.;8 39544 changes to: (FNS DISMISS) (VARS LLBASICCOMS) previous date: " 6-Aug-84 13:23:13" {ERIS}<LISPCORE>SOURCES>LLBASIC.;7) (* Copyright (c) 1981, 1982, 1983, 1984 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT LLBASICCOMS) (RPAQQ LLBASICCOMS ((FNS LISTP LITATOM FIXP STRINGP SMALLP SMALLPOSP NLISTP ARRAYP ATOM FLOATP NUMBERP STACKP) [COMS (* ufns) (FNS INITUFNTABLE \SETUFNENTRY) (FNS \UNKNOWN.UFN) (DECLARE: DONTCOPY (RECORDS UFNENTRY) (ADDVARS (INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS INITUFNTABLE] (DECLARE: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 SMALLPOSP SETXVAR SETQ.NOREF IEQ) (TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF) (CONSTANTS WordsPerPage))) [COMS (* atoms) (FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST SETPROPLIST) (FNS \MKATOM NewAtom \INITATOMPAGE \GCPNAMES) (FNS MAPATOMS) (FNS INITATOMS COPYATOM UNCOPYATOM) (COMS (* See EXPORTS comment below) (VARS (\PNAMELIMIT 255))) (FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN \SMASHATOM) (VARS (COMPILEATPUTDFLG)) (DECLARE: DONTCOPY (EXPORT * ATOMEXPORTS)) (DECLARE: EVAL@COMPILE DONTCOPY (MACROS \EQBYTES) (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL] (COMS (* for executing boot expressions when first run) (FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT) (GLOBALVARS RESETFORMS BOOTFILES)) [COMS (* date/time, stats) (FNS CLOCK DAYTIME ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE) (FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER) (DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (PROP MACRO ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE] (COMS (* Fast functions for moving and clearing storage) (FNS \MOVEBYTES \BLT \ZEROWORDS \MOVEWORDS \ZEROBYTES)) (LOCALVARS . T) (DECLARE: DONTCOPY (COMS * LLBMAKEINITCOMS)))) (DEFINEQ (LISTP [LAMBDA (X) (* lmm "10-MAR-81 15:01") (* usually done in microcode) (AND (EQ (NTYPX X) \LISTP) X]) (LITATOM [LAMBDA (X) (* lmm "10-MAR-81 15:05") (* compiles open to NTYPX check) (EQ (NTYPX X) \LITATOM]) (FIXP [LAMBDA (X) (* lmm "10-MAR-81 15:08") (* compiles open to TYPEPs) (SELECTC (NTYPX X) ((LIST \SMALLP \FIXP) X) NIL]) (STRINGP [LAMBDA (X) (* lmm "10-MAR-81 15:09") (* compiles open to TYPEP) (SELECTC (NTYPX X) (\STRINGP X) NIL]) (SMALLP [LAMBDA (X) (* lmm "10-MAR-81 15:10") (* compiles open to TYPEP) (SELECTC (NTYPX X) (\SMALLP X) NIL]) (SMALLPOSP [LAMBDA (X) (* lmm " 9-NOV-81 21:21") (EQ (\HILOC X) \SmallPosHi]) (NLISTP [LAMBDA (X) (* lmm "10-MAR-81 15:07") (* compiles open) (NOT (LISTP X]) (ARRAYP [LAMBDA (X) (* lmm "10-MAR-81 15:11") (* compiles open to TYPEP) (SELECTC (NTYPX X) (\ARRAYP X) NIL]) (ATOM [LAMBDA (X) (* lmm "10-MAR-81 15:08") (* compiles open) (SELECTC (NTYPX X) ((LIST \SMALLP \FIXP \FLOATP \LITATOM) T) NIL]) (FLOATP [LAMBDA (X) (* lmm "10-MAR-81 15:11") (* compiles open to TYPEP) (SELECTC (NTYPX X) (\FLOATP X) NIL]) (NUMBERP [LAMBDA (X) (* lmm "10-MAR-81 15:12") (SELECTC (NTYPX X) ((LIST \FIXP \SMALLP \FLOATP) X) NIL]) (STACKP [LAMBDA (X) (* lmm "10-MAR-81 15:13") (SELECTC (NTYPX X) (\STACKP X) NIL]) ) (* ufns) (DEFINEQ (INITUFNTABLE [LAMBDA NIL (* rmk: "11-OCT-83 13:29") (for I from 0 to 255 do (\SETUFNENTRY I (QUOTE \UNKNOWN.UFN) 0 0)) (for X in \OPCODES when (fetch (OPCODE UFNFN) of X) do (\SETUFNENTRY (fetch (OPCODE OP#) of X) (fetch (OPCODE UFNFN) of X) (IDIFFERENCE (IPLUS 1 (COND ((ZEROP (fetch (OPCODE OPNARGS) of X)) 0) (T 1))) (fetch (OPCODE LEVADJ) of X)) (fetch (OPCODE OPNARGS) of X]) (\SETUFNENTRY (LAMBDA (INDEX FN NARGS NEXTRA) (* JonL "16-Dec-83 22:51") (SETQ INDEX (\ADDBASE (\ADDBASE \UFNTable INDEX) INDEX)) (replace (UFNENTRY FNINDEX) of INDEX with (\ATOMDEFINDEX FN)) (replace (UFNENTRY NEXTRA) of INDEX with NEXTRA) (replace (UFNENTRY NARGS) of INDEX with NARGS))) ) (DEFINEQ (\UNKNOWN.UFN [LAMBDA NIL (* 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 BYTEMACRO [OPENLAMBDA (A) (PROG NIL (\PUTBASE A 1 ([LAMBDA (J) (DECLARE (LOCALVARS . T)) (COND ((EQ J MAX.SMALL.INTEGER) [\PUTBASE A 0 (COND ((EQ (\GETBASE A 0) MAX.POS.HINUM) 0) (T (ADD1 (\GETBASE A 0] 0) (T (ADD1 J] (\GETBASE A 1]) (PUTPROPS SMALLPOSP MACRO ((X) (EQ (\HILOC X) (CONSTANT \SmallPosHi)))) (PUTPROPS SETXVAR MACRO [X (COND ((EQ (CAAR X) (QUOTE QUOTE)) (LIST (QUOTE SETQ) (CADAR X) (CADR X))) ((LITATOM (CAR X)) (LIST (QUOTE SET) (CAR X) (CADR X))) (T (HELP (CONS X (QUOTE (bad SETXVAR form]) (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X) (QUOTE QUOTE)) (LITATOM (CADAR X))) (SHOULDNT)) (GLOBALVARS \VALSPACE) (LIST (QUOTE SETQ.NOREF) (CADAR X) (CADR X)))) (PUTPROPS SETQ.NOREF DMACRO ((VAR VALUE) (\PUTBASEPTR \VALSPACE (LLSH (\ATOMVALINDEX (QUOTE VAR)) 1) VALUE))) (PUTPROPS IEQ DMACRO (= . EQ)) (PUTPROPS IEQ MACRO ((X Y) (IEQP X Y))) ) (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) (* JonL " 1-May-84 11:03") (PROG ((L 1) (H 0) H1 P Q C) (COND ((EQ 0 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 0 (SETQ P (\GETBASE \AtomHashTable H))) (COND ((UNLESSRDSYS (AND (EQ (fetch (LITATOM PNAMELENGTH) of (SETQ Q (\ADDBASE \ATOMSPACE (SUB1 P)))) LEN) (\EQBYTES (fetch (LITATOM PNAMEBASE) of Q) 1 BASE OFFST LEN)) (EQ (\INDEXATOMPNAME (SETQ Q (SUB1 P))) BASE)) (RETURN Q)) (T (SETQ H (LOGAND (IPLUS H \HashInc) \AtomHTmask)) (GO LP))))) (* Not found, must make new atom) (RETURN (NewAtom BASE OFFST LEN H))))) (NewAtom (LAMBDA (BASE BN LEN H) (* JonL " 1-May-84 11:54") (DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE)) (PROG (ATM PB CPP PNP) (RETURN (UNINTERRUPTABLY (SETQ ATM \AtomFrLst) (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) (ADD1 LEN)) (* Not enough space left on this pname page to hold all the characters for the new atom.) (\GCPNAMES))) (COND ((EVENP ATM (TIMES 2 WORDSPERPAGE)) (* MDS pages are allocated in two-page chunks now) (PROG ((PN (FOLDLO ATM WORDSPERPAGE))) (COND ((IGEQ PN (IDIFFERENCE \LastAtomPage 1)) (* 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))))) (\MAKEMDSENTRY PN (LOGOR \TT.NOREF \LITATOM)) (* Make entry in MDS type table) (\INITATOMPAGE PN) (* Make Def'n, TopVal, and Plist pages exist, and initialize) )) ((IGEQ ATM (IDIFFERENCE \AtomHTmask 1)) (* This test is fast) (\MP.ERROR \MP.ATOMSFULL "No more atoms left"))) (\PUTBASEPTR (\ADDBASE2 \PNPSPACE ATM) 0 (SETQ PNP (\VAG2 (IPLUS \PnCharsFblock (LRSH CPP 8)) (IPLUS (LLSH (LOGAND CPP 255) 8) (LRSH PB 1))))) (* PNAME starts on byte 1 always - byte 0 is the length) (\MOVEBYTES BASE BN PNP 1 LEN) (\PUTBASEBYTE PNP 0 LEN) (SETQ.NOREF \AtomFrLst (\PUTBASE \AtomHashTable H (ADD1 ATM))) (* * 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))) (\ADDBASE \ATOMSPACE ATM)))))) (\INITATOMPAGE (LAMBDA (PN) (* JonL " 1-May-84 12:01") (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 by WORDSPERCELL until (IGREATERP I (SUB1 (ITIMES WORDSPERPAGE 4))) do (\PUTBASEPTR VALBASE I (EVQ (QUOTE NOBIND))))))) (\GCPNAMES [LAMBDA NIL (* bvm: "23-Mar-84 18:32") (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 \PnCharsFblock 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]) ) (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) (* lmm " 6-Aug-84 13:16") (* this is used only by RDSYS to turn atom numbers into names) (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]) ) (* See EXPORTS comment below) (RPAQQ \PNAMELIMIT 255) (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) (* rmk: "23-OCT-82 14:32") (PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN)) [BLOCKINFO (PROGN (* Reserve enough space. FILECODEBLOCK leaves file pointing at first data word, so BASE is set to that below. BLOCKINFO is used for setting block trailer.) (FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL) (fetch (CODEARRAY ALIGNED) of CA] (BASE (FILEARRAYBASE))) (replace (DEFINITIONCELL DEFPOINTER) of DCELL with BASE) (replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (CODEARRAY ARGTYPE) of CA)) (replace (DEFINITIONCELL FASTP) of DCELL with (ZEROP (fetch (CODEARRAY NTSIZE) of CA))) (replace (DEFINITIONCELL CCODEP) of DCELL with T) (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL) [COND ((FMEMB FN LOCKEDFNS) (\LOCKCELL DCELL 1) (\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE) (FOLDHI SIZE BYTESPERWORD)) WORDSPERPAGE] [COND ((EQ FN (LOCAL (FUNCTION \RESETSTACK))) (SETQ RESETPTR (FILEARRAYBASE)) (SETQ RESETPC (fetch (CODEARRAY STARTPC) of CA] (AOUT CA 0 SIZE OUTX (QUOTE CODE)) (BOUTZEROS (MODUP SIZE BYTESPERCELL)) (FILEBLOCKTRAILER BLOCKINFO]) (GETDEFN [LAMBDA (A) (* lmm "20-AUG-81 12:17") (fetch (LITATOM DEFPOINTER) of A]) (\SMASHATOM [LAMBDA (A) (* rmk: "11-OCT-83 13:32") (replace (LITATOM PNAMELENGTH) of A with 0]) ) (RPAQQ COMPILEATPUTDFLG NIL) (DECLARE: DONTCOPY (RPAQQ ATOMEXPORTS ((RECORDS LITATOM VCELL VALINDEX) (RECORDS DEFINITIONCELL FNHEADER) (E (* MACROS should go away in favor of record access)) (MACROS \ATOMVALINDEX \ATOMDEFINDEX \ATOMPNAMEINDEX \ATOMPROPINDEX \INDEXATOMPNAME \INDEXATOMVAL \INDEXATOMDEF) (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \SCRATCHSTRING COMPILEATPUTDFLG) (CONSTANTS (\LastAtomPage 127) (\PNAMELIMIT 255) (\CharsPerPnPage 512) (\AtomHTmask 32767) (\PnCharsFblock 24)) (* \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 ((PNPCELL (\ADDBASE \PNPSPACE (UNFOLD (\ATOMPROPINDEX DATUM) WORDSPERCELL))) (DEFINITIONCELL (\ADDBASE \DEFSPACE (UNFOLD (\ATOMDEFINDEX DATUM) WORDSPERCELL))) (PROPCELL (\ADDBASE \PLISTSPACE (UNFOLD (\ATOMPROPINDEX DATUM) WORDSPERCELL))) (VALINDEX (\ATOMVALINDEX DATUM))) (TYPE? (LITATOM DATUM)) [BLOCKRECORD PNPCELL ((PNAMEBASE FULLXPOINTER)) (BLOCKRECORD PNAMEBASE ((PNAMELENGTH BYTE] (BLOCKRECORD PROPCELL ((NIL BITS 1) (GENSYMP FLAG) (NIL BITS 6) (PROPLIST POINTER)))) (BLOCKRECORD VCELL ((VALUE FULLPOINTER))) (ACCESSFNS VALINDEX [(VCELL (\ADDBASE \VALSPACE (UNFOLD DATUM WORDSPERCELL]) ] [DECLARE: EVAL@COMPILE (BLOCKRECORD DEFINITIONCELL ((CCODEP FLAG) (FASTP FLAG) (ARGTYPE BITS 2) (PSEUDOCODEP FLAG) (NIL BITS 3) (DEFPOINTER POINTER))) (BLOCKRECORD FNHEADER ((STKMIN WORD) (NA SIGNEDWORD) (PV SIGNEDWORD) (STARTPC WORD) (NIL FLAG) (NIL FLAG) (ARGTYPE BITS 2) (NIL BITS 4) (#FRAMENAME XPOINTER) (NTSIZE WORD) (NLOCALS BYTE) (FVAROFFSET BYTE)) [ACCESSFNS FNHEADER ((LSTARP (ILESSP (fetch (FNHEADER NA) of DATUM) 0)) (OVERHEADWORDS (PROGN 8)) (ALIGNED (IPLUS (fetch (FNHEADER NTSIZE) of DATUM) (fetch (FNHEADER OVERHEADWORDS) of T))) (FIXED NIL (replace (FNHEADER STKMIN) of DATUM with (IPLUS (UNFOLD (IPLUS (fetch (FNHEADER NA) of DATUM) (UNFOLD (ADD1 (fetch (FNHEADER PV) of DATUM)) CELLSPERQUAD)) WORDSPERCELL) 12 32))) (NPVARWORDS (UNFOLD (ADD1 (fetch (FNHEADER PV) of DATUM)) WORDSPERQUAD)) (FRAMENAME (fetch (FNHEADER #FRAMENAME) of DATUM) (UNINTERRUPTABLY (CHECK (NEQ (\HILOC DATUM) \STACKHI)) (\DELREF (fetch (FNHEADER #FRAMENAME) of DATUM)) (\ADDREF NEWVALUE) (replace (FNHEADER #FRAMENAME) of DATUM with NEWVALUE))]) ] (DECLARE: EVAL@COMPILE (PUTPROPS \ATOMVALINDEX DMACRO (= . \LOLOC)) (PUTPROPS \ATOMDEFINDEX DMACRO (= . \LOLOC)) (PUTPROPS \ATOMPNAMEINDEX DMACRO (= . \LOLOC)) (PUTPROPS \ATOMPROPINDEX DMACRO (= . \LOLOC)) (PUTPROPS \INDEXATOMPNAME DMACRO ((X) (\VAG2 \AtomHI X))) (PUTPROPS \INDEXATOMVAL DMACRO ((X) (\VAG2 \AtomHI X))) (PUTPROPS \INDEXATOMDEF DMACRO ((X) (\VAG2 \AtomHI X))) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \SCRATCHSTRING COMPILEATPUTDFLG) ) (DECLARE: EVAL@COMPILE (RPAQQ \LastAtomPage 127) (RPAQQ \PNAMELIMIT 255) (RPAQQ \CharsPerPnPage 512) (RPAQQ \AtomHTmask 32767) (RPAQQ \PnCharsFblock 24) (CONSTANTS (\LastAtomPage 127) (\PNAMELIMIT 255) (\CharsPerPnPage 512) (\AtomHTmask 32767) (\PnCharsFblock 24)) ) (DECLARE: EVAL@COMPILE (PUTPROPS GETPROPLIST DMACRO [(ATM) (ffetch (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM]) (PUTPROPS SETPROPLIST DMACRO ((ATM LST) (freplace (LITATOM PROPLIST) of (\DTEST ATM (QUOTE LITATOM)) with LST))) ) (* END EXPORTED DEFINITIONS) ) (DECLARE: EVAL@COMPILE DONTCOPY (DECLARE: EVAL@COMPILE (PUTPROPS \EQBYTES MACRO [LAMBDA (BASE1 BN1 BASE2 BN2 LEN) (PROG NIL LP (COND ((ZEROP LEN) (RETURN T)) ((NEQ (\GETBASEBYTE BASE1 BN1) (\GETBASEBYTE BASE2 BN2)) (RETURN)) (T (add BN1 1) (add BN2 1) (add LEN -1) (GO LP]) ) (ADDTOVAR DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL) ) (* for executing boot expressions when first run) (DEFINEQ (\RESETSYSTEMSTATE [LAMBDA NIL (* rmk: " 5-JUN-81 17:32") (\KEYBOARDON T) (\RESETTERMINAL]) (INITIALEVALQT [LAMBDA NIL (* bvm: "21-APR-83 12:02") (DECLARE (GLOBALVARS BOOTFILES)) (\SETIOPOINTERS) (PROG ((RL BOOTFILES) FL L) (OR RL (RETURN)) (SIMPLEPRINT "evaluating initial expressions: ") (* BOOTFILES is the list of boot files in reverse order) R (SETQ FL (CONS (CAR RL) FL)) (COND ((SETQ RL (CDR RL)) (GO R))) L1 [COND ([LISTP (SETQ L (GETTOPVAL (CAR FL] (SIMPLEPRINT (CAR FL)) (* Print the name of the bootfile) (DSPBOUT (CHARCODE CR)) (PROG NIL L2 [EVAL (PROG1 (CAR L) (SETTOPVAL (CAR FL) (SETQ L (CDR L] (AND (LISTP L) (GO L2))) (SETTOPVAL (CAR FL) (QUOTE NOBIND] (COND ((SETQ FL (CDR FL)) (GO L1))) (SETQ BOOTFILES NIL) (INTERPRET.REM.CM) (* See if command line has anything to say) ) (* Value is T so that correct value is returned when this is called from within COPYSYS0) T]) (SIMPLEPRINT [LAMBDA (X N) (* lmm "17-MAY-80 20:19") (COND [(OR (LITATOM X) (STRINGP X)) (for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I] ((LISTP X) (COND ((ZEROP N) (SIMPLEPRINT "&")) (T (DSPBOUT (CHARCODE %()) (PROG NIL LP [SIMPLEPRINT (CAR X) (SETQ N (COND ((SMALLPOSP N) (SUB1 N)) (T 3] (COND ((ZEROP N) (SIMPLEPRINT " --)")) ((NULL (SETQ X (CDR X))) (SIMPLEPRINT ")")) ((NLISTP X) (SIMPLEPRINT " . ") (SIMPLEPRINT X) (SIMPLEPRINT ")")) (T (SIMPLEPRINT " ") (GO LP]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (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 (\MOVEBYTES [LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (* rmk: "23-OCT-82 14:24") (* Simple version for bootstrapping) (COND ((IGREATERP NBYTES 0) (PROG ((SB (\ADDBASE SBASE (FOLDLO SBYTE BYTESPERWORD))) (DB (\ADDBASE DBASE (FOLDLO DBYTE BYTESPERWORD))) SBN DBN NWORDS) (COND [(EQ (SETQ SBN (IMOD SBYTE BYTESPERWORD)) (SETQ DBN (IMOD DBYTE BYTESPERWORD))) (* Can move words) (COND ((EQ SBN 1) (\PUTBASEBYTE DB 1 (\GETBASEBYTE SB 1)) (SETQ DB (\ADDBASE DB 1)) (SETQ SB (\ADDBASE SB 1)) (add NBYTES -1))) (\BLT DB SB (SETQ NWORDS (FOLDLO NBYTES BYTESPERWORD))) (COND ((EQ (IMOD NBYTES BYTESPERWORD) 1) (\PUTBASEBYTE (\ADDBASE DB NWORDS) 0 (\GETBASEBYTE (\ADDBASE SB NWORDS) 0] (T (FRPTQ NBYTES (\PUTBASEBYTE DB (PROG1 DBN (add DBN 1)) (\GETBASEBYTE SB (PROG1 SBN (add SBN 1]) (\BLT [LAMBDA (DBASE SBASE NWORDS) (* JonL "21-Jan-84 05:21") (* Generally in ucode -- must guarantee transferral by moving high-order address first) (for I from (SUB1 NWORDS) by -1 to 0 do (\PUTBASE (\ADDBASE DBASE I) 0 (\GETBASE (\ADDBASE SBASE I) 0))) DBASE]) (\ZEROWORDS [LAMBDA (BASE ENDBASE) (* bvm: "27-NOV-82 17:23") (* Bootstrapping version of \ZEROWORDS) [COND ((NOT (PTRGTP BASE ENDBASE)) (COND ([AND (EVENP (\LOLOC BASE)) (NOT (EVENP (\LOLOC ENDBASE] (* Can transfer two words at a time) (for (B ← BASE) by (\ADDBASE B 2) do (\PUTBASEPTR B 0 NIL) repeatuntil (EQ (\ADDBASE B 1) ENDBASE))) (T (for (B ← BASE) by (\ADDBASE B 1) do (\PUTBASE B 0 0) repeatuntil (EQ B ENDBASE] BASE]) (\MOVEWORDS [LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (* bvm: "15-JUN-82 13:56") (\BLT (\ADDBASE DBASE DOFFSET) (\ADDBASE SBASE SOFFSET) NWORDS]) (\ZEROBYTES [LAMBDA (BASE FIRST LAST) (* bvm: "24-MAY-82 21:46") (* Redefined by \LONGZEROBYTES) (FRPTQ (ADD1 (IDIFFERENCE LAST FIRST)) (PROGN (\PUTBASEBYTE BASE FIRST 0) (add FIRST 1))) NIL]) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (LOCALVARS) ) (DECLARE: DONTCOPY (RPAQQ LLBMAKEINITCOMS [(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] (DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL))) (EXPANDMACROFNS SMALLPOSP \EQBYTES) (MKI.SUBFNS (MKNUMATOM . NILL) (\ATOMDEFINDEX . I.ATOMNUMBER) (\ATOMVALINDEX . I.ATOMNUMBER) (\ATOMPROPINDEX . I.ATOMNUMBER) (\ATOMPNAMEINDEX . I.ATOMNUMBER) (SETQ.NOREF . SETQ) (\BITBLT.CUTOFF . 256) (SETTOPVAL . I.FSETVAL)) (RD.SUBFNS (MKNUMATOM . NILL) (\ATOMDEFINDEX . VATOMNUMBER) (\ATOMPROPINDEX . VATOMNUMBER) (\ATOMVALINDEX . VATOMNUMBER) (SETQ.NOREF . SETQ) (\BITBLT.CUTOFF . 256) (\INDEXATOMPNAME . VATOM) (\INDEXATOMVAL . VATOM) (\INDEXATOMDEF . VATOM) (NewAtom . ERROR!)) (RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \SMASHATOM) (FNS LISTP) (VARS (COPYATOMSTR))) (RD.SUBFNS (\RPLPTR . VPUTBASEPTR)) (RDVALS (\AtomFrLst]) (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 DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL))) (ADDTOVAR EXPANDMACROFNS SMALLPOSP \EQBYTES) (ADDTOVAR MKI.SUBFNS (MKNUMATOM . NILL) (\ATOMDEFINDEX . I.ATOMNUMBER) (\ATOMVALINDEX . I.ATOMNUMBER) (\ATOMPROPINDEX . I.ATOMNUMBER) (\ATOMPNAMEINDEX . I.ATOMNUMBER) (SETQ.NOREF . SETQ) (\BITBLT.CUTOFF . 256) (SETTOPVAL . I.FSETVAL)) (ADDTOVAR RD.SUBFNS (MKNUMATOM . NILL) (\ATOMDEFINDEX . VATOMNUMBER) (\ATOMPROPINDEX . VATOMNUMBER) (\ATOMVALINDEX . VATOMNUMBER) (SETQ.NOREF . SETQ) (\BITBLT.CUTOFF . 256) (\INDEXATOMPNAME . VATOM) (\INDEXATOMVAL . VATOM) (\INDEXATOMDEF . VATOM) (NewAtom . ERROR!)) (ADDTOVAR RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \SMASHATOM) (FNS LISTP) (VARS (COPYATOMSTR))) (ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR)) (ADDTOVAR RDVALS (\AtomFrLst)) ) (PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984)) (DECLARE: DONTCOPY (FILEMAP (NIL (2138 4815 (LISTP 2148 . 2385) (LITATOM 2387 . 2616) (FIXP 2618 . 2883) (STRINGP 2885 . 3132) (SMALLP 3134 . 3379) (SMALLPOSP 3381 . 3494) (NLISTP 3496 . 3703) (ARRAYP 3705 . 3950) (ATOM 3952 . 4224) (FLOATP 4226 . 4471) (NUMBERP 4473 . 4657) (STACKP 4659 . 4813)) (4833 5824 (INITUFNTABLE 4843 . 5437) (\SETUFNENTRY 5439 . 5822)) (5825 6019 (\UNKNOWN.UFN 5835 . 6017)) (8400 9847 (GETTOPVAL 8410 . 8585) (SETTOPVAL 8587 . 8962) (FSETVAL 8964 . 9196) (\SETGLOBALVAL.UFN 9198 . 9371) ( \SETFVAR.UFN 9373 . 9512) (GETPROPLIST 9514 . 9670) (SETPROPLIST 9672 . 9845)) (9848 15839 (\MKATOM 9858 . 11783) (NewAtom 11785 . 14510) (\INITATOMPAGE 14512 . 15413) (\GCPNAMES 15415 . 15837)) (15840 16105 (MAPATOMS 15850 . 16103)) (16106 19393 (INITATOMS 16116 . 18143) (COPYATOM 18145 . 18788) ( UNCOPYATOM 18790 . 19391)) (19461 23782 (\DEFINEDP 19471 . 19655) (PUTD 19657 . 20119) (\PUTD 20121 . 21327) (GETD 21329 . 21961) (PUTDEFN 21963 . 23450) (GETDEFN 23452 . 23606) (\SMASHATOM 23608 . 23780) ) (28572 30760 (\RESETSYSTEMSTATE 28582 . 28712) (INITIALEVALQT 28714 . 29989) (SIMPLEPRINT 29991 . 30758)) (30861 32725 (CLOCK 30871 . 31931) (DAYTIME 31933 . 32191) (ALTO.TO.LISP.DATE 32193 . 32577) ( LISP.TO.ALTO.DATE 32579 . 32723)) (32726 33447 (PAGEFAULTS 32736 . 32929) (\SETTOTALTIME 32931 . 33298 ) (\SERIALNUMBER 33300 . 33445)) (33775 36473 (\MOVEBYTES 33785 . 34876) (\BLT 34878 . 35322) ( \ZEROWORDS 35324 . 35961) (\MOVEWORDS 35963 . 36149) (\ZEROBYTES 36151 . 36471))))) STOP