(FILECREATED "24-Sep-86 18:00:26" {ERIS}<LISPCORE>SOURCES>LLBASIC.;57
 66171  

      changes to:  (VARS LLBASICCOMS)

      previous date: "16-Sep-86 17:46:37" {ERIS}<LISPCORE>SOURCES>LLBASIC.;56)


(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT LLBASICCOMS)

(RPAQQ LLBASICCOMS
 
       ((FNS LISTP LITATOM FIXP STRINGP SMALLP NLISTP ARRAYP ATOM FLOATP NUMBERP STACKP)
        (DECLARE: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR 
                                          SETQ.NOREF IEQ)
                                  (TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF)
                                  (CONSTANTS WordsPerPage)))
        (COMS (* "atoms")
              (FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST \ATOMCELL 
                   SETPROPLIST)
              (COMS (MACROS \PROPCELL)
                    (OPTIMIZERS \ATOMCELL GETPROPLIST SETPROPLIST))
              (FNS \MKATOM \CREATE.SYMBOL \MKATOM.FULL \INITATOMPAGE)
              (FNS MAPATOMS ATOMHASH#PROBES)
              (FNS INITATOMS COPYATOM UNCOPYATOM)
              (COMS (* "See \PNAMELIMIT comment below")
                    (VARS (\PNAMELIMIT 255))
                    (INITVARS (\PNAMES.IN.BLOCKS?)))
              (FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN)
              (VARS (COMPILEATPUTDFLG))
              (INITVARS (*PACKAGE-FROM-INDEX*))
              (DECLARE: DONTCOPY (EXPORT (RECORDS LITATOM SYMBOL VALINDEX VCELL DEFINITIONCELL 
                                                FNHEADER PNAMECELL PACKAGEINDEX PNAMEBASE PNAMEINDEX)
                                        (MACROS \DEFCELL \VALCELL \PNAMECELL)
                                        (MACROS \ATOMVALINDEX \ATOMDEFINDEX \ATOMPNAMEINDEX 
                                               \ATOMPROPINDEX \INDEXATOMPNAME \INDEXATOMVAL 
                                               \INDEXATOMDEF)
                                        (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst 
                                               \OneCharAtomBase \PNAMES.IN.BLOCKS? \SCRATCHSTRING 
                                               COMPILEATPUTDFLG *PACKAGE-FROM-INDEX*)
                                        (CONSTANTS (\PNAMELIMIT 255)
                                               (\CharsPerPnPage 512))
                                        (* "\PNAMELIMIT is exported but needs to also be a VARS on this file to get it copied.  Note that both commands must be edited together.  "
                                           )))
              (DECLARE: EVAL@COMPILE DONTCOPY (MACROS COMPUTE.ATOM.HASH ATOM.HASH.REPROBE)
                     (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL))
                     ))
        (COMS (* "for executing boot expressions when first run")
              (FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT)
              (GLOBALVARS RESETFORMS BOOTFILES))
        (COMS (* "stats")
              (FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER))
        (COMS (* "Fast functions for moving and clearing storage")
              (FNS \BLT \MOVEBYTES \CLEARWORDS \CLEARBYTES \CLEARCELLS)
              (DECLARE: EVAL@COMPILE DONTCOPY (MACROS .CLEARNWORDS.))
              (* "Obsolete:")
              (DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \MOVEWORDS)))
              (FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS))
        (LOCALVARS . T)
        (DECLARE: DONTCOPY (ADDVARS (INITVALUES (\AtomFrLst 0))
                                  (INITPTRS (\OneCharAtomBase NIL)
                                         (\SCRATCHSTRING))
                                  (INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT \ATOMCELL)
                                         (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES)
                                         (FNS COPYATOM INITATOMS))
                                  (EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE 
                                         \DEFCELL \VALCELL \PNAMECELL \PROPCELL \INDEXATOMPNAME)
                                  (MKI.SUBFNS (\PARSE.NUMBER . NILL)
                                         (\MKATOM.FULL . NILL)
                                         (\ATOMDEFINDEX . I.ATOMNUMBER)
                                         (\ATOMVALINDEX . I.ATOMNUMBER)
                                         (\ATOMPROPINDEX . I.ATOMNUMBER)
                                         (\ATOMPNAMEINDEX . I.ATOMNUMBER)
                                         (SETQ.NOREF . SETQ)
                                         (SETTOPVAL . I.FSETVAL))
                                  (RD.SUBFNS (\PARSE.NUMBER . NILL)
                                         (\ATOMDEFINDEX . VATOMNUMBER)
                                         (\ATOMPROPINDEX . VATOMNUMBER)
                                         (\ATOMVALINDEX . VATOMNUMBER)
                                         (SETQ.NOREF . SETQ)
                                         (\INDEXATOMPNAME . VATOM)
                                         (\INDEXATOMVAL . VATOM)
                                         (\INDEXATOMDEF . VATOM)
                                         (\CREATE.SYMBOL . VNOSUCHATOM))
                                  (RDCOMS (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST 
                                               SETTOPVAL GETDEFN \ATOMCELL)
                                         (FNS LISTP)
                                         (VARS (COPYATOMSTR)))
                                  (RD.SUBFNS (\RPLPTR . VPUTBASEPTR))
                                  (RDVALS (\AtomFrLst))))
        (PROP FILETYPE LLBASIC)))
(DEFINEQ

(LISTP

  (LAMBDA (X)
                                                (* bvm: "30-Jan-85 10:56")

                                                             (* usually done in microcode)

    (AND (EQ (NTYPX X)
             \LISTP)
         (COND
            ((EQ CDRCODING 0)
             T)
            (T                                               (* Check that it is not a list page 

                                                             header. This is mostly for benefit of 

                                                             teleraid)

               (NEQ (fetch (POINTER WORDINPAGE)
                           of X)
                    0)))
         X)))

(LITATOM

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:05")

                                                             (* compiles open to NTYPX check)

    (EQ (NTYPX X)
        \LITATOM)))

(FIXP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:08")

                                                             (* compiles open to TYPEPs)

    (\TYPEMASK.UFN X (LRSH \TT.FIXP 8))))

(STRINGP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:09")

                                                             (* compiles open to TYPEP)

    (SELECTC (NTYPX X)
        (\STRINGP X)
        NIL)))

(SMALLP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:10")

                                                             (* compiles open to TYPEP)

    (SELECTC (NTYPX X)
        (\SMALLP X)
        NIL)))

(NLISTP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:07")

                                                             (* compiles open)

    (NOT (LISTP
 X))))

(ARRAYP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:11")

                                                             (* compiles open to TYPEP)

    (SELECTC (NTYPX X)
        (\ARRAYP X)
        NIL)))

(ATOM

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:08")

                                                             (* compiles open)

    (\MACRO.MX (ATOM
 X))))

(FLOATP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:11")

                                                             (* compiles open to TYPEP)

    (SELECTC (NTYPX X)
        (\FLOATP X)
        NIL)))

(NUMBERP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:12")

    (\TYPEMASK.UFN X (LRSH \TT.NUMBERP 8))))

(STACKP

  (LAMBDA (X)
                                                (* lmm "10-MAR-81 15:13")

    (SELECTC (NTYPX X)
        (\STACKP X)
        NIL)))
)
(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE 

(PUTPROPS CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK))
                                        CHECK)
                                   (CONS (QUOTE PROGN)
                                         (for I in ARGS collect
                                              (LIST (QUOTE OR)
                                                    I
                                                    (LIST (QUOTE RAID)
                                                          (KWOTE (LIST (QUOTE Check-failure:)
                                                                       I)))))))
                                  (T (CONS COMMENTFLG ARGS)))))
(PUTPROPS \StatsZero BYTEMACRO (OPENLAMBDA (N)
                                      (\PUTBASE N 0 0)
                                      (\PUTBASE N 1 0)))
(PUTPROPS \StatsAdd1 DMACRO (OPENLAMBDA (A)
                                   (PROG ((LO (IPLUS16 (\GETBASE A 1)
                                                     1)))
                                         (DECLARE (LOCALVARS LO))
                                         (* Increment double word at A by 1)
                                         (\PUTBASE A 1 LO)
                                         (COND ((EQ LO 0)
                                                (\PUTBASE A 0 (ADD1 (\GETBASE A 0))))))))
(PUTPROPS IPLUS16 MACRO ((X Y)
                         (* Kludge to do 16-bit plus)
                         (\LOLOC (\ADDBASE X Y))))
(PUTPROPS SMALLPOSP MACRO (OPENLAMBDA (X)
                                 (AND (SMALLP X)
                                      (IGEQ X 0))))
(PROGN (PUTPROPS SETXVAR MACRO (X (BQUOTE (SETQ.NOREF , (CADAR X)
                                                 ,
                                                 (CADR X)))))
       (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X)
                                                (QUOTE QUOTE))
                                            (LITATOM (CADAR X)))
                                       (SHOULDNT))
                                   (GLOBALVARS \VALSPACE)
                                   (LIST (QUOTE SETQ.NOREF)
                                         (CADAR X)
                                         (CADR X)))))
(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL)
                             (\PUTBASEPTR (LOCF (fetch (LITATOM VALUE)
                                                       of
                                                       (QUOTE VAR)))
                                    0 VAL)))
(PROGN (PUTPROPS IEQ MACRO ((X Y)
                            (IEQP X Y)))
       (PUTPROPS IEQ DMACRO (= . EQ)))
)
(SETTEMPLATE (QUOTE SPREADAPPLY*)
       (QUOTE (FUNCTIONAL .. EVAL)))
(SETTEMPLATE (QUOTE SPREADAPPLY)
       (QUOTE (FUNCTIONAL EVAL . PPE)))
(SETTEMPLATE (QUOTE SETQ.NOREF)
       (QUOTE (SET EVAL . PPE)))
(DECLARE: EVAL@COMPILE 

(RPAQQ WordsPerPage
 256)

(CONSTANTS WordsPerPage)
)


(* END EXPORTED DEFINITIONS)

)



(* "atoms")


(DEFINEQ

(GETTOPVAL

  (LAMBDA (X)
                                                (* edited: " 3-Apr-85 16:38")

    (fetch (LITATOM
 VALUE)
           of X)))

(SETTOPVAL

  (LAMBDA (ATM VAL)
                                          (* edited: " 3-Apr-85 19:37")

    (SELECTQ ATM
        (NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
        (T (OR (EQ VAL T)
               (LISPERROR "ATTEMPT TO SET NIL OR T" VAL)))
        (replace (LITATOM
 VALUE)
               of ATM with (UNLESSRDSYS VAL (\COPY VAL))))))

(FSETVAL

  (LAMBDA (ATM VAL)
                                          (* edited: " 3-Apr-85 19:36")

                                                             (* SETTOPVAL WITHOUT ERROR CHECKS FOR 

                                                             MAKEINIT ONLY)

    (replace (LITATOM
 VALUE)
           of ATM with VAL)))

(\SETGLOBALVAL.UFN

  (LAMBDA (V A)
                                              (* bvm: " 6-Jun-85 11:54")

    (replace (VALINDEX VALUE)
           of A with V)))

(\SETFVAR.UFN

  (LAMBDA (V VCELL)
                                          (* edited: " 3-Apr-85 16:40")

    (replace (VCELL VALUE)
           of VCELL with V)))

(GETPROPLIST

  (LAMBDA (ATM)
                                              (* edited: " 3-Apr-85 16:40")

    (\GETBASEPTR (\PROPCELL ATM)
           0)))

(\ATOMCELL

  (LAMBDA (X N)
                                              (* lmm "20-Mar-86 16:30")

    (LET ((LOC (SELECTC N
                   (\DEF.HI (\ATOMDEFINDEX X))
                   (\VAL.HI (\ATOMVALINDEX X))
                   (\PLIST.HI (\ATOMPROPINDEX X))
                   (\PNAME.HI (\ATOMPNAMEINDEX X))
                   (SHOULDNT))))
         (\ADDBASE (\VAG2 N LOC)
                LOC))))

(SETPROPLIST

  (LAMBDA (ATM LST)
                                          (* edited: " 3-Apr-85 16:41")

    (replace (LITATOM
 PROPLIST)
           of ATM with LST)))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS \PROPCELL MACRO ((ATOM)
                           (\ATOMCELL ATOM (CONSTANT \PLIST.HI))))
)
(DEFOPTIMIZER \ATOMCELL
 (&REST X) (LET ((CE (CONSTANTEXPRESSIONP (CADR X))))
                                       (COND
                                          (CE (BQUOTE ((OPCODES ATOMCELL.N , (CAR CE))
                                                       ,
                                                       (CAR X))))
                                          (T (QUOTE IGNOREMACRO)))))

(DEFOPTIMIZER GETPROPLIST
 (X) (BQUOTE (\GETBASEPTR (\PROPCELL (\, X))
                                             0)))

(DEFOPTIMIZER SETPROPLIST
 (ATM LST) (BQUOTE (\RPLPTR (\PROPCELL (\, ATM))
                                                   0
                                                   (\, LST))))

(DEFINEQ

(\MKATOM

  (LAMBDA (BASE OFFST LEN FATP NONNUMERICP)
                  (* bvm: " 3-Aug-86 15:24")

    (PROG ((FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST to (SUB1 (IPLUS OFFST LEN))
                                                   suchthat
                                                   (IGREATERP (\GETBASEFAT BASE I)
                                                          \MAXTHINCHAR))))))
           HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE)
                                                             (* Because FATCHARSEENP is used in an 

                                                             EQ check later, it must be NIL or T 

                                                             only, hence the (NOT

                                                             (NULL ...)))

          (COND
             ((EQ LEN 0)                                     (* The Zero-length atom has hash code 

                                                             zero)

              (SETQ HASH 0)
              (SETQ FIRSTBYTE 255)
              (GO LP)))
          (SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST)
                                 (NTHCHARCODE BASE OFFST)))  (* Grab the first character of the 

                                                             atom)

          (UNLESSRDSYS (COND
                          ((AND (EQ LEN 1)
                                (ILEQ FIRSTCHAR \MAXTHINCHAR)
                                \OneCharAtomBase)            (* The one-character atoms live in 

                                                             well known places, no need to hash)

                           (RETURN (COND
                                      ((IGREATERP FIRSTCHAR (CHARCODE "9"))
                                       (\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10)))
                                      ((IGEQ FIRSTCHAR (CHARCODE "0"))
                                                             (* These one-character atoms are 

                                                             integers. Sigh)

                                       (IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
                                      (T (\ADDBASE \OneCharAtomBase FIRSTCHAR)))))
                          ((AND (NOT NONNUMERICP)
                                (ILEQ FIRSTCHAR (CHARCODE "9"))
                                (SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE)))
                                                             (* \PARSE.NUMBER returns a number or 

                                                             NIL)

                           (RETURN HASHENT))))               (* Calculate first probe)

          (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))            (* First byte is used to compute hash 

                                                             and reprobe. Use lower order byte of 

                                                             first character, since chances are 

                                                             that has the most information)

          (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)  (* Build a hash value for this atom 

                                                             from the PNAME)

      LP                                                     (* Top of the probe-and-compare-PNAMEs 

                                                             loop.)

          (COND
             ((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
                                                             (* HASHENT is one greater than the 

                                                             atom number, so that atom zero can be 

                                                             stored. Go from atom number to pname, 

                                                             compare strings)

              (COND
                 ((UNLESSRDSYS (AND (EQ (ffetch (PNAMEBASE PNAMELENGTH)
                                               of
                                               (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE)
                                                                   of
                                                                   (SETQ ATM# (SUB1 HASHENT)))))
                                        LEN)
                                    (EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE 
                                                                                  PNAMEFATPADDINGBYTE
                                                                                      )
                                                                              of PNBASE))
          
          (* Extra memory references to get the FATPNAMEP bit, so do a quick and dirty 

          heuristic, based on the fact that the second byte of a fatpname is always 

          0--wouldn't be worth it if the fatbit were more easily accessible)


                                                                 )
                                                          (ffetch (LITATOM
 FATPNAMEP)
                                                                 of
                                                                 (\ADDBASE \ATOMSPACE ATM#))))
                                    (COND
                                       (FATCHARSEENP         (* FATCHARSEENP=T now implies that 

                                                             both the probe and target are fat)

                                              (for B1 from 1 to LEN as B2 from OFFST always 
                                                             (* Loop thru the characters in the 

                                                             putative atom and the existing PNAME, 

                                                             to see if they're the same)

                                                   (EQ (\GETBASEFAT PNBASE B1)
                                                       (\GETBASEFAT BASE B2))))
                                       (FATP                 (* The incoming string is fat, but 

                                                             there are no fat characters in the 

                                                             PNAME.)

                                             (for B1 from 1 to LEN as B2 from OFFST always
                                                  (EQ (\GETBASETHIN PNBASE B1)
                                                      (\GETBASEFAT BASE B2))))
                                       (T                    (* Both the incoming string of chars 

                                                             and the PNAME are thin.)

                                          (for B1 from 1 to LEN as B2 from OFFST always
                                               (EQ (\GETBASETHIN PNBASE B1)
                                                   (\GETBASETHIN BASE B2))))))
                         (EQ (\INDEXATOMPNAME (SETQ ATM# (SUB1 HASHENT)))
                             BASE))
                  (RETURN (\ADDBASE \ATOMSPACE ATM#)))
                 (T                                          (* Doesn't match, so reprobe.

                                                             Want reprobe to be variable, 

                                                             preferably independent of primary 

                                                             probe.)

                    (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH 
                                                                              FIRSTBYTE)))))
                    (GO LP)))))                              (* Not found, must make new atom)

          (RETURN (UNINTERRUPTABLY
                      (LET ((NEWATOM (\CREATE.SYMBOL
 BASE OFFST LEN FATP FATCHARSEENP)))
                           (UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM)
                                                                            )))
                           NEWATOM))))))

(\CREATE.SYMBOL

  (LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP)
                (* bvm: "13-Jun-86 17:25")

          
          (* * Creates a new symbol whose pname is as indicated.

          FATP means the presented string is fat, while FATCHARSEENP means that there 

          actually is a fat char in there (otherwise we will store a thin pname) -

          Must be called UNINTERRUPTABLY and the caller is responsible for interning the 

          symbol wherever it belongs)


    (LET ((PNBASE (\ALLOCBLOCK (COND
                                  (FATCHARSEENP              (* Allocate us a bunch of word-sized 

                                                             chars in pname space)

                                         (FOLDHI (ADD1 LEN)
                                                WORDSPERCELL))
                                  (T                         (* Allocation is in CELLS)

                                     (FOLDHI (ADD1 LEN)
                                            BYTESPERCELL)))))
          PB CPP ATM)
         (COND
            ((EVENP (SETQ ATM \AtomFrLst)
                    \MDSIncrement)                           (* MDS pages are allocated in two-page 

                                                             chunks now)

             (PROG ((PN (FOLDLO ATM WORDSPERPAGE)))
                   (COND
                      ((IGEQ PN (IDIFFERENCE \LastAtomPage 1))
                       (\MKATOM.FULL
)))
                   (\MAKEMDSENTRY PN (LOGOR \TT.NOREF \TT.ATOM \LITATOM))
                                                             (* Make entry in MDS type table)

                   (\INITATOMPAGE
 PN)                        (* Make Def'n, TopVal, and Plist pages 

                                                             exist, and initialize)

               ))
            ((EQ ATM \MaxAtomFrLst)                          (* This test is fast)

             (\MP.ERROR \MP.ATOMSFULL "No more atoms left")))
         (replace (PNAMEINDEX PNAMEBASE)
                of ATM with PNBASE)                          (* PNAME starts on byte 1 always -

                                                             byte 0 is the length)

         (COND
            (FATCHARSEENP (\BLT
 (\ADDBASE PNBASE 1)
                                (\ADDBASE BASE OFFSET)
                                LEN))
            (FATP (for I from OFFSET as J from 1 to LEN do (\PUTBASETHIN PNBASE J (\GETBASEFAT BASE I
                                                                                         ))))
            (T (\MOVEBYTES
 BASE OFFSET PNBASE 1 LEN)))
         (replace (PNAMEBASE PNAMELENGTH)
                of PNBASE with LEN)
         (COND
            ((NOT \IN.MAKEINIT)                              (* Make the pname block permanent, 

                                                             since the replace above did not addref 

                                                             it)

             (\ADDREF PNBASE)))
         (SETQ \AtomFrLst (ADD1 ATM))
         (SETQ ATM (\ADDBASE \ATOMSPACE ATM))
         (COND
            (FATCHARSEENP (freplace (LITATOM
 FATPNAMEP)
                                 of ATM with T)))
         ATM)))

(\MKATOM.FULL

  (LAMBDA NIL
                                                (* bvm: " 7-May-86 12:25")

          
          (* * Cause a STORAGEFULL interrupt on the first atom of the penultimate page --

          that should give "early" warning.)


    (DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
    (COND
       ((NOT \STORAGEFULL)
        (SETQ \STORAGEFULL T)
        (replace STORAGEFULL of \INTERRUPTSTATE with T)
        (SETQ \PENDINGINTERRUPT T)))
    NIL))

(\INITATOMPAGE

  (LAMBDA (PN)
                                               (* bvm: "18-Jan-85 16:02")

    (PROG ((OFFSET (UNFOLD PN WORDSPERPAGE))
           VALBASE)
          
          (* PN is the page number of the first atom.

          OFFSET is the first atom. Have to double that to get offsets in \DEFSPACE etc.

          Atoms, like everything, are allocated in double pages, so the 4 spaces have to 

          be allocated in quad pages)

          
          (* * assumes CCODEP bit in definition cell is default "OFF" , so it's ok to 

          have all def pages zero to start)


          (\NEW4PAGE (\ADDBASE2 \PNPSPACE OFFSET))
          (\NEW4PAGE (\ADDBASE2 \DEFSPACE OFFSET))
          (\NEW4PAGE (\ADDBASE2 \PLISTSPACE OFFSET))
          (\NEW4PAGE (SETQ VALBASE (\ADDBASE2 \VALSPACE OFFSET)))
          (FRPTQ (ITIMES CELLSPERPAGE 4)                     (* Initialize value pages to value 

                                                             NOBIND)

                 (\PUTBASEPTR VALBASE 0 (EVQ (QUOTE NOBIND)))
                 (SETQ VALBASE (\ADDBASE VALBASE WORDSPERCELL))))))
)
(DEFINEQ

(MAPATOMS

  (LAMBDA (FN)
    (DECLARE (LOCALVARS . T))
                                (* lmm "13-FEB-83 13:33")

    (PROG ((A 0))
      LP  (APPLY* FN (\INDEXATOMPNAME A))
          (COND
             ((EQ (SETQ A (ADD1 A))
                  \AtomFrLst)
              (RETURN)))
          (GO LP))))

(ATOMHASH#PROBES

  (LAMBDA (STRING)
                                           (* bvm: " 8-Jul-86 21:50")

          
          (* * Looks up STRING (a string or litatom) in atom hash table.

          If found, returns number of probes needed to find it, a minimum of one.

          If not found, returns NIL)


    (PROG (DESIREDATOM# BASE OFFST LEN FIRSTBYTE FIRSTCHAR HASH HASHENT PNBASE REPROBE FATCHARSEENP 
                 FATP)
          (COND
             ((LITATOM
 STRING)
              (SETQ BASE (ffetch (LITATOM
 PNAMEBASE)
                                of STRING))
              (SETQ OFFST 1)
              (SETQ LEN (ffetch (LITATOM
 PNAMELENGTH)
                               of STRING))
              (SETQ FATP (SETQ FATCHARSEENP (ffetch (LITATOM
 FATPNAMEP)
                                                   of STRING)))
              (SETQ DESIREDATOM# (\LOLOC STRING)))
             (T (SETQ BASE (ffetch (STRINGP
 BASE)
                                  of
                                  (SETQ STRING (MKSTRING STRING))))
                (SETQ OFFST (ffetch (STRINGP
 OFFST)
                                   of STRING))
                (SETQ LEN (ffetch (STRINGP
 LENGTH)
                                 of STRING))
                (COND
                   ((SETQ FATP (ffetch (STRINGP
 FATSTRINGP)
                                      of STRING))
                    (SETQ FATCHARSEENP (for C infatstring STRING when (IGREATERP C \MAXTHINCHAR)
                                            do
                                            (RETURN T)))))
                (OR (ILEQ LEN \PNAMELIMIT)
                    (RETURN))))
          (SETQ FIRSTCHAR (\GETBASECHAR FATP BASE OFFST))
          (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255))
          (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP)
          (RETURN (for PROBES from 1 until (EQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH)))
                       do
                       (COND
                          ((COND
                              (DESIREDATOM# (EQ DESIREDATOM# (SUB1 HASHENT)))
                              (T (AND (EQ (fetch (PNAMEBASE PNAMELENGTH)
                                                 of
                                                 (SETQ PNBASE (fetch (PNAMEINDEX PNAMEBASE)
                                                                     of
                                                                     (SUB1 HASHENT))))
                                          LEN)
                                      (EQ FATCHARSEENP (ffetch (LITATOM
 FATPNAMEP)
                                                              of
                                                              (\ADDBASE \ATOMSPACE (SUB1 HASHENT))))
                                      (COND
                                         (FATCHARSEENP       (* FATCHARSEENP=T now implies that 

                                                             both the probe and target are fat)

                                                (for B1 from 1 to LEN as B2 from OFFST always 
                                                             (* Loop thru the characters in the 

                                                             putative atom and the existing PNAME, 

                                                             to see if they're the same)

                                                     (EQ (\GETBASEFAT PNBASE B1)
                                                         (\GETBASEFAT BASE B2))))
                                         (FATP               (* The incoming string is fat, but 

                                                             there are no fat characters in the 

                                                             PNAME.)

                                               (for B1 from 1 to LEN as B2 from OFFST always
                                                    (EQ (\GETBASETHIN PNBASE B1)
                                                        (\GETBASEFAT BASE B2))))
                                         (T                  (* Both the incoming string of chars 

                                                             and the PNAME are thin.)

                                            (for B1 from 1 to LEN as B2 from OFFST always
                                                 (EQ (\GETBASETHIN PNBASE B1)
                                                     (\GETBASETHIN BASE B2))))))))
                           (RETURN PROBES)))                 (* Doesn't match, so reprobe.

                                                             Want reprobe to be variable, 

                                                             preferably independent of primary 

                                                             probe.)

                       (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH 
                                                                                 FIRSTBYTE))))))))))
)
(DEFINEQ

(INITATOMS

  (LAMBDA NIL
                                                (* bvm: "14-Jun-86 17:19")

                                                             (* E (RADIX 8))

                                                             (* called only under MAKEINIT to 

                                                             initialize the making of atoms)

    (CREATEPAGES \AtomHashTable \AtomHTpages)
    (SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT))
    (LET ((BASE (ffetch (STRINGP
 BASE)
                       of \SCRATCHSTRING))
          (OFFST (ffetch (STRINGP
 OFFST)
                        of \SCRATCHSTRING)))                 (* (CREATEPAGES \PNCHARSSPACE 1))

         (COPYATOM
 NIL)
         (COPYATOM
 (QUOTE NOBIND))
         (for C from 0 to 255 when (OR (ILESSP C 48)
                                       (IGEQ C 58))
              do
              (\PUTBASEBYTE BASE OFFST C)
              (\MKATOM
 BASE OFFST 1))
         (SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2))
         (COPYATOM
 (FUNCTION \EVALFORM))                     (* atom 248)

         (COPYATOM
 (FUNCTION \GC.HANDLEOVERFLOW))            (* atom 249)

         (COPYATOM
 (FUNCTION \DTEST.UFN))                    (* atom 250)

         (COPYATOM
 (FUNCTION \OVERFLOWMAKENUMBER))           (* atom 251)

         (COPYATOM
 (FUNCTION \MAKENUMBER))                   (* atom 252)

         (COPYATOM
 (FUNCTION \SETGLOBAL.UFN))                (* atom 253)

         (COPYATOM
 (FUNCTION \SETFVAR.UFN))                  (* atom 254)

         (COPYATOM
 (FUNCTION \GCMAPTABLE))                   (* atom 255)

         (COPYATOM
 (FUNCTION \INTERPRETER))                  (* atom 256)

         (OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER))
                 256)
             (HELP (FUNCTION \INTERPRETER)
                   " not atom 400Q")))))

(COPYATOM

  (LAMBDA (X)
                                                (* lmm "13-FEB-83 13:27")

          
          (* this function is only for the use of MAKEINIT, which passes it a real atom 

          to be translated into an atom in the remote sysout -

          \SCRATCHSTRING is initialized in INITATOMS)


    (PROG ((N (LOCAL (NCHARS X)))
           (BASE (ffetch (STRINGP
 BASE)
                        of \SCRATCHSTRING))
           (OFFST (ffetch (STRINGP
 OFFST)
                         of \SCRATCHSTRING)))
          (for I from 1 to N do (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1))
                                       (LOCAL (NTHCHARCODE X I))))
          (RETURN (\ATOMDEFINDEX (\MKATOM
 BASE OFFST N))))))

(UNCOPYATOM

  (LAMBDA (N)
                                                (* bvm: "22-Jan-85 11:37")

                                                             (* this is used only by RDSYS to turn 

                                                             atom numbers into names)

    (PROG ((ADDR (\GETBASEPTR (\ADDBASE2 \PNPSPACE N)
                        0))
           (STR (OR COPYATOMSTR (SETQ COPYATOMSTR (LOCAL (ALLOCSTRING \PNAMELIMIT)))))
           LEN)
          (SETQ LEN (\GETBASEBYTE ADDR 0))
          (for I from 1 to LEN do (LOCAL (RPLSTRING COPYATOMSTR I (FCHARACTER (\GETBASEBYTE ADDR I)))
                                         ))
          (RETURN (LOCAL (SUBATOM COPYATOMSTR 1 LEN))))))
)



(* "See \PNAMELIMIT comment below")



(RPAQQ \PNAMELIMIT
 255)

(RPAQ? \PNAMES.IN.BLOCKS?
 )
(DEFINEQ

(\DEFINEDP

  (LAMBDA (A)
                                                (* edited: " 3-Apr-85 19:45")

    (AND (LITATOM
 A)
         (fetch (LITATOM
 DEFPOINTER)
                of A)
         T)))

(PUTD

  (LAMBDA (FN DEF FLG)
                                       (* bvm: " 7-Jul-86 17:06")

    (PROG1 DEF (COND
                  ((AND (NULL FLG)
                        (TYPEP DEF (QUOTE COMPILED-CLOSURE))
                        (NEQ (fetch (COMPILED-CLOSURE FRAMENAME)
                                    of DEF)
                             FN))                            (* Definition being stored has a 

                                                             different frame name, so fix it)

                   (SETQ DEF (\RENAMEDFN DEF FN))))
           (\PUTD
 FN DEF))))

(\PUTD

  (LAMBDA (FN DEF)
                                           (* bvm: " 8-Jul-86 16:34")

    (LET ((DCELL (fetch (LITATOM
 DEFINITIONCELL)
                        of FN)))
         (UNINTERRUPTABLY
             (PROG ((DVAL DEF)
                    CODEBASE)
                   (COND
                      ((TYPEP DVAL (QUOTE COMPILED-CLOSURE))
                       (SETQ CODEBASE (fetch (COMPILED-CLOSURE FNHEADER)
                                             of DVAL))
                       (replace (DEFINITIONCELL PSEUDOCODEP)
                              of DCELL with NIL)
                       (COND
                          ((fetch (COMPILED-CLOSURE ENVIRONMENT)
                                  of DVAL)                   (* Full closure, have to store it as 

                                                             non-ccodep)

                           (replace CCODEP of DCELL with NIL)
                           (GO CLOSURE))
                          (T                                 (* Strip out code base)

                             (SETQ DVAL CODEBASE))))
                      ((AND (ARRAYP
 DVAL)
                            (EQ (fetch (ARRAYP
 TYP)
                                       of DVAL)
                                \ST.CODE))                   (* Code array -- only from the code 

                                                             reader or compiler)

                       (SETQ CODEBASE (SETQ DVAL (fetch (ARRAYP
 BASE)
                                                        of DVAL)))
                       (replace (DEFINITIONCELL PSEUDOCODEP)
                              of DCELL with NIL))
                      ((AND COMPILEATPUTDFLG (LISTP
 DVAL))
                       (SETQ DVAL (SETQ CODEBASE (OR (\MAKEPSEUDOCODE DVAL FN)
                                                     (GO EXPR))))
                       (replace (DEFINITIONCELL PSEUDOCODEP)
                              of DCELL with T))
                      (T (GO EXPR)))
               CODE
                   (replace (DEFINITIONCELL CCODEP)
                          of DCELL with T)
               CLOSURE
                   (replace (DEFINITIONCELL ARGTYPE)
                          of DCELL with (fetch (FNHEADER ARGTYPE)
                                               of CODEBASE))
                   (replace (DEFINITIONCELL FASTP)
                          of DCELL with (EQ 0 (fetch (FNHEADER NTSIZE)
                                                     of CODEBASE)))
                   (replace (DEFINITIONCELL DEFPOINTER)
                          of DCELL with DVAL)
                   (RETURN DEF)
               EXPR
                   (replace (DEFINITIONCELL DEFCELLFLAGS)
                          of DCELL with 0)
                   (replace (DEFINITIONCELL DEFPOINTER)
                          of DCELL with DVAL)
                   (RETURN DEF))))))

(GETD

  (LAMBDA (A)
                                                (* bvm: " 7-Jul-86 16:46")

    (COND
       ((LITATOM
 A)
        (LET ((A (fetch (LITATOM
 DEFINITIONCELL)
                        of A)))
             (COND
                ((NOT (fetch (DEFINITIONCELL CCODEP)
                             of A))
                 (fetch (DEFINITIONCELL DEFPOINTER)
                        of A))
                ((fetch (DEFINITIONCELL PSEUDOCODEP)
                        of A)
                 (\PSEUDOCODE.REALDEF (fetch (DEFINITIONCELL DEFPOINTER)
                                             of A)))
                (T (create COMPILED-CLOSURE FNHEADER _ (fetch (DEFINITIONCELL DEFPOINTER)
                                                              of A)))))))))

(PUTDEFN

  (LAMBDA (FN CA SIZE)
                                       (* edited: " 3-Apr-85 19:55")

                                                             (* special version of PUTD that runs 

                                                             only at MAKEINIT time)

    (PROG ((DCELL (fetch (LITATOM
 DEFINITIONCELL)
                         of FN))
           (BLOCKINFO (PROGN 
          
          (* Reserve enough space. FILECODEBLOCK leaves file pointing at first data word, 

          so BASE is set to that below. BLOCKINFO is used for setting block trailer.)


                             (FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL)
                                    (fetch (CODEARRAY ALIGNED)
                                           of CA))))
           (BASE (FILEARRAYBASE)))
          (replace (DEFINITIONCELL DEFPOINTER)
                 of DCELL with BASE)
          (replace (DEFINITIONCELL ARGTYPE)
                 of DCELL with (fetch (CODEARRAY ARGTYPE)
                                      of CA))
          (replace (DEFINITIONCELL FASTP)
                 of DCELL with (EQ (fetch (CODEARRAY NTSIZE)
                                          of CA)
                                   0))
          (replace (DEFINITIONCELL CCODEP)
                 of DCELL with T)
          (replace (DEFINITIONCELL PSEUDOCODEP)
                 of DCELL with NIL)
          (COND
             ((FMEMB FN LOCKEDFNS)
              (\LOCKCELL DCELL 1)
              (\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE)
                                                    of BASE)
                                             (FOLDHI SIZE BYTESPERWORD))
                                     WORDSPERPAGE))))
          (COND
             ((EQ FN (LOCAL (FUNCTION \RESETSTACK)))         (* special kludge to remember where 

                                                             \RESETSTACK is in the MAKEINIT)

              (SETQ RESETPTR (FILEARRAYBASE))
              (SETQ RESETPC (fetch (CODEARRAY STARTPC)
                                   of CA))))
          (AOUT CA 0 SIZE OUTX (QUOTE CODE))
          (BOUTZEROS (MODUP SIZE BYTESPERCELL))
          (FILEBLOCKTRAILER BLOCKINFO))))

(GETDEFN

  (LAMBDA (A)
                                                (* lmm "20-AUG-81 12:17")

    (fetch (LITATOM
 DEFPOINTER)
           of A)))
)

(RPAQQ COMPILEATPUTDFLG
 NIL)

(RPAQ? *PACKAGE-FROM-INDEX*
 )
(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


[DECLARE: EVAL@COMPILE 

(ACCESSFNS LITATOM
 ((DEFINITIONCELL (\DEFCELL DATUM))
                    (PROPCELL (\PROPCELL DATUM))
                    (VCELL (\VALCELL DATUM))
                    (PNAMECELL (\PNAMECELL DATUM)))
          
          (* * VCELL can also be accessed directly from a value index via the record 

          VALINDEX (as in \SETGLOBALVAL.UFN) -

          Similarly, PNAMEINDEX accesses PNAMECELL for use by \MKATOM and UNCOPYATOM)


                   (TYPE?
 (LITATOM DATUM))
                   (BLOCKRECORD PROPCELL ((NIL BITS 1)
                                          (GENSYMP FLAG)
                                          (FATPNAMEP FLAG)
                                          (NIL BITS 5)
                                          (PROPLIST POINTER))))

(SYNONYM SYMBOL
 (LITATOM))

(ACCESSFNS VALINDEX
 ((VCELL (\ADDBASE2 \VALSPACE DATUM))))

(BLOCKRECORD VCELL
 ((VALUE FULLPOINTER)))

(BLOCKRECORD DEFINITIONCELL
 ((CCODEP FLAG)
                             (FASTP FLAG)
                             (ARGTYPE BITS 2)
                             (PSEUDOCODEP FLAG)
                             (NIL BITS 3)
                             (DEFPOINTER POINTER))
                            (BLOCKRECORD DEFINITIONCELL ((DEFCELLFLAGS BYTE)
                                                         (NIL POINTER))))

(BLOCKRECORD FNHEADER
 ((STKMIN WORD)
                       (NA SIGNEDWORD)
                       (PV SIGNEDWORD)
                       (STARTPC WORD)
                       (NIL FLAG)
                       (NIL FLAG)
                       (ARGTYPE BITS 2)
                       (NIL BITS 3)
                       (CLOSUREP FLAG)
                       (#FRAMENAME XPOINTER)
                       (NTSIZE WORD)
                       (NLOCALS BYTE)
                       (FVAROFFSET BYTE))
                      (ACCESSFNS
                       FNHEADER
                       ((LSTARP (ILESSP (fetch
 (FNHEADER NA) of
 DATUM)
                                       0))
                        (OVERHEADWORDS (PROGN 8))
                        (ALIGNED (IPLUS (fetch
 (FNHEADER NTSIZE) of
 DATUM)
                                        (fetch
 (FNHEADER OVERHEADWORDS) of
 T)))
                        (FIXED NIL (replace
 (FNHEADER STKMIN) of
 DATUM
                                      with
 (IPLUS (UNFOLD (IPLUS (fetch
 (FNHEADER NA) of
 DATUM)
                                                                 (UNFOLD (ADD1 (fetch
 (FNHEADER
                                                                                       PV)
                                                                                  of
 DATUM))
                                                                        CELLSPERQUAD))
                                                         WORDSPERCELL)
                                                  12 32)))
                        (NPVARWORDS (UNFOLD (ADD1 (fetch
 (FNHEADER PV) of
 DATUM))
                                           WORDSPERQUAD))
                        (FRAMENAME (fetch
 (FNHEADER #FRAMENAME) of
 DATUM)
                               (UNINTERRUPTABLY
                                   (CHECK (NEQ (\HILOC DATUM)
                                               \STACKHI))
                                   (\DELREF (fetch
 (FNHEADER #FRAMENAME) of
 DATUM))
                                   (\ADDREF NEWVALUE)
                                   (replace
 (FNHEADER #FRAMENAME) of
 DATUM with
 NEWVALUE))))))

(BLOCKRECORD PNAMECELL
 ((PACKAGEINDEX BYTE)
                        (PNAMEBASE XPOINTER))
                       (BLOCKRECORD PNAMECELL ((FULLPNAMEBASE FULLXPOINTER)
                                                             (* 

                                                           "Replacing this smashes PACKAGEINDEX to 0")

                                               ))
                       (ACCESSFNS PNAMECELL ((PACKAGE (AREF *PACKAGE-FROM-INDEX* (FETCH
 (PNAMECELL
                                                                                         PACKAGEINDEX
                                                                                         )
                                                                                    OF
 DATUM))
                                                    (REPLACE
 (PNAMECELL PACKAGEINDEX) OF
 DATUM
                                                       WITH
 (IF
 (NULL NEWVALUE)
                                                                THEN
 *UNINTERNED-PACKAGE-INDEX*
                                                              ELSE
 (PACKAGE-INDEX NEWVALUE)))))))

(ACCESSFNS PACKAGEINDEX
 ((PACKAGE (AREF *PACKAGE-FROM-INDEX* DATUM))))

(BLOCKRECORD PNAMEBASE
 ((PNAMELENGTH BYTE)                   (* Length is always here, be the pname 

                                                             thin or fat)

                        (PNAMEFATPADDINGBYTE BYTE)           (* This byte is zero for fat pnames so 

                                                             that the pname chars are word-aligned)

                        ))

(ACCESSFNS PNAMEINDEX
 ((PNAMECELL (\ADDBASE (\VAG2 \PNAME.HI (\LOLOC DATUM))
                                         (\LOLOC DATUM)))))
]
(DECLARE: EVAL@COMPILE 

(PUTPROPS \DEFCELL MACRO ((ATOM)
                          (\ATOMCELL ATOM \DEF.HI)))
(PUTPROPS \VALCELL MACRO ((ATOM)
                          (\ATOMCELL ATOM \VAL.HI)))
(PUTPROPS \PNAMECELL MACRO ((ATOM)
                            (\ATOMCELL ATOM \PNAME.HI)))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS \ATOMVALINDEX DMACRO ((X)
                                (\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMDEFINDEX DMACRO ((X)
                                (\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMPNAMEINDEX DMACRO ((X)
                                  (\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \ATOMPROPINDEX DMACRO ((X)
                                 (\LOLOC (\DTEST X (QUOTE LITATOM)))))
(PUTPROPS \INDEXATOMPNAME DMACRO ((X)
                                  (\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMVAL DMACRO ((X)
                                (\VAG2 \AtomHI X)))
(PUTPROPS \INDEXATOMDEF DMACRO ((X)
                                (\VAG2 \AtomHI X)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \PNAMES.IN.BLOCKS? 
       \SCRATCHSTRING COMPILEATPUTDFLG *PACKAGE-FROM-INDEX*)
)
(DECLARE: EVAL@COMPILE 

(RPAQQ \PNAMELIMIT
 255)

(RPAQQ \CharsPerPnPage
 512)

(CONSTANTS (\PNAMELIMIT 255)
       (\CharsPerPnPage 512))
)


(* END EXPORTED DEFINITIONS)

)
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS COMPUTE.ATOM.HASH MACRO ((BASE OFFST LEN FIRSTBYTE FATP)
                                   (* Sets variable HASH to atom hash of indicated string)
                                   (SETQ HASH (LLSH FIRSTBYTE 8))
                                   (for CHAR# from (ADD1 OFFST)
                                        to
                                        (SUB1 (IPLUS OFFST LEN))
                                        do
                                        (SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH
                                                                           (IPLUS16
                                                                            HASH
                                                                            (LLSH (LOGAND HASH 4095)
                                                                                  2)))
                                                                   (LLSH (LOGAND HASH 255)
                                                                         8))
                                                          (UNLESSRDSYS (COND
                                                                        (FATP (LOGAND (\GETBASEFAT
                                                                                       BASE CHAR#)
                                                                                     255))
                                                                        (T (\GETBASETHIN BASE CHAR#))
                                                                        )
                                                                 (NTHCHARCODE BASE CHAR#)))))))
(PUTPROPS ATOM.HASH.REPROBE MACRO ((HASH FIRSTBYTE)
                                   (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH)))))
)


(ADDTOVAR DONTCOMPILEFNS
 INITATOMS COPYATOM UNCOPYATOM GETDEFN PUTDEFN FSETVAL)
)



(* "for executing boot expressions when first run")


(DEFINEQ

(\RESETSYSTEMSTATE

  (LAMBDA NIL
                                                (* rmk: " 5-JUN-81 17:32")

    (\KEYBOARDON T)
    (\RESETTERMINAL)))

(INITIALEVALQT

  (LAMBDA NIL
                                                (* bvm: "21-APR-83 12:02")

    (DECLARE (GLOBALVARS BOOTFILES))
    (\SETIOPOINTERS)
    (PROG ((RL BOOTFILES)
           FL L)
          (OR RL (RETURN))
          (SIMPLEPRINT
 "evaluating initial expressions:
")                                                           (* BOOTFILES is the list of boot files 

                                                             in reverse order)

      R   (SETQ FL (CONS (CAR RL)
                         FL))
          (COND
             ((SETQ RL (CDR RL))
              (GO R)))
      L1  (COND
             ((LISTP
 (SETQ L (GETTOPVAL
 (CAR FL))))
              (SIMPLEPRINT
 (CAR FL))                         (* Print the name of the bootfile)

              (DSPBOUT (CHARCODE CR))
              (PROG NIL
                L2  (EVAL (PROG1 (CAR L)
                                 (SETTOPVAL
 (CAR FL)
                                        (SETQ L (CDR L)))))
                    (AND (LISTP
 L)
                         (GO L2)))
              (SETTOPVAL
 (CAR FL)
                     (QUOTE NOBIND))))
          (COND
             ((SETQ FL (CDR FL))
              (GO L1)))
          (SETQ BOOTFILES NIL)
          (INTERPRET.REM.CM)                                 (* See if command line has anything to 

                                                             say)

      )                                                      (* Value is T so that correct value is 

                                                             returned when this is called from 

                                                             within COPYSYS0)

    T))

(SIMPLEPRINT

  (LAMBDA (X N)
                                              (* bvm: "13-Feb-85 22:25")

    (COND
       ((OR (LITATOM
 X)
            (STRINGP
 X))
        (for I from 1 to (NCHARS X)
             do
             (DSPBOUT (NTHCHARCODE X I))))
       ((LISTP
 X)
        (COND
           ((EQ N 0)
            (SIMPLEPRINT
 "&"))
           (T (DSPBOUT (CHARCODE %())
              (PROG NIL
                LP  (SIMPLEPRINT
 (CAR X)
                           (SETQ N (COND
                                      ((SMALLPOSP N)
                                       (SUB1 N))
                                      (T 3))))
                    (COND
                       ((EQ N 0)
                        (SIMPLEPRINT
 " --)"))
                       ((NULL (SETQ X (CDR X)))
                        (SIMPLEPRINT
 ")"))
                       ((NLISTP
 X)
                        (SIMPLEPRINT
 " . ")
                        (SIMPLEPRINT
 X)
                        (SIMPLEPRINT
 ")"))
                       (T (SIMPLEPRINT
 " ")
                          (GO LP))))))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS RESETFORMS BOOTFILES)
)



(* "stats")


(DEFINEQ

(PAGEFAULTS

  (LAMBDA NIL
                                                (* rrb "13-NOV-80 15:36")

    (DECLARE (GLOBALVARS \MISCSTATS))
    (fetch PAGEFAULTS of \MISCSTATS)))

(\SETTOTALTIME

  (LAMBDA NIL
                                                (* JonL "17-Dec-83 00:23")

                                                             (* updates the total time field of the 

                                                             misc stats page.)

    (\BOXIPLUS (LOCF (fetch TOTALTIME of \MISCSTATS))
           (CLOCKDIFFERENCE (fetch STARTTIME of \MISCSTATS)))))

(\SERIALNUMBER

  (LAMBDA NIL
                                                (* rmk: " 9-JUN-81 14:49")

    (fetch (IFPAGE SerialNumber)
           of \InterfacePage)))
)



(* "Fast functions for moving and clearing storage")


(DEFINEQ

(\BLT

  (LAMBDA (DBASE SBASE NWORDS)
                               (* lmm "30-Mar-85 05:43")

                                                             (* Generally in ucode --

                                                             must guarantee transferral by moving 

                                                             high-order address first)

    (PROG ((NN (CONSTANT (EXPT 2 14))))
          (RETURN (COND
                     ((GREATERP NWORDS NN)                   (* dorado has microcode only for up to 

                                                             2^15)

                      (\BLT
 (\ADDBASE DBASE NN)
                            (\ADDBASE SBASE NN)
                            (DIFFERENCE NWORDS NN))
                      (\BLT
 DBASE SBASE NN))
                     (T (for I from (SUB1 NWORDS)
                             by -1 to 0 do (\PUTBASE DBASE I (\GETBASE SBASE I)))
                        DBASE))))))

(\MOVEBYTES

  (LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES)
                   (* rmk: "23-OCT-82 14:24")

                                                             (* Simple version for bootstrapping)

    (COND
       ((IGREATERP NBYTES 0)
        (PROG ((SB (\ADDBASE SBASE (FOLDLO SBYTE BYTESPERWORD)))
               (DB (\ADDBASE DBASE (FOLDLO DBYTE BYTESPERWORD)))
               SBN DBN NWORDS)
              (COND
                 ((EQ (SETQ SBN (IMOD SBYTE BYTESPERWORD))
                      (SETQ DBN (IMOD DBYTE BYTESPERWORD)))  (* Can move words)

                  (COND
                     ((EQ SBN 1)
                      (\PUTBASEBYTE DB 1 (\GETBASEBYTE SB 1))
                      (SETQ DB (\ADDBASE DB 1))
                      (SETQ SB (\ADDBASE SB 1))
                      (add NBYTES -1)))
                  (\BLT
 DB SB (SETQ NWORDS (FOLDLO NBYTES BYTESPERWORD)))
                  (COND
                     ((EQ (IMOD NBYTES BYTESPERWORD)
                          1)
                      (\PUTBASEBYTE (\ADDBASE DB NWORDS)
                             0
                             (\GETBASEBYTE (\ADDBASE SB NWORDS)
                                    0)))))
                 (T (FRPTQ NBYTES (\PUTBASEBYTE DB (PROG1 DBN (add DBN 1))
                                         (\GETBASEBYTE SB (PROG1 SBN (add SBN 1))))))))))))

(\CLEARWORDS

  (LAMBDA (BASE NWORDS)
                                      (* bvm: "20-Feb-85 12:30")

    (PROG1 BASE (while (IGREATERP NWORDS 32767)
                       do                                    (* BLT wants NWORDS to be small.

                                                             We play it safe by keeping the count 

                                                             smaller than 2^15, avoiding a Dorado 

                                                             uCode bug)

                       (.CLEARNWORDS. BASE 32768)
                       (SETQ BASE (\ADDBASE BASE 32768))
                       (SETQ NWORDS (IDIFFERENCE NWORDS 32768)))
           (COND
              ((IGREATERP NWORDS 0)
               (.CLEARNWORDS. BASE NWORDS))))))

(\CLEARBYTES

  (LAMBDA (BASE OFFST NBYTES)
                                (* bvm: "29-Jan-85 18:56")

    (COND
       ((IGREATERP NBYTES 0)
        (COND
           ((ODDP OFFST)
            (\PUTBASEBYTE BASE OFFST 0)
            (add OFFST 1)
            (add NBYTES -1)))                                (* OFFST is now even)

        (SETQ BASE (\ADDBASE BASE (FOLDLO OFFST BYTESPERWORD)))
        (COND
           ((ODDP NBYTES)                                    (* Final byte to be zeroed)

            (\PUTBASEBYTE BASE (SUB1 NBYTES)
                   0)))                                      (* Now all we have to do is zero the 

                                                             word-aligned part in the middle)

        (\CLEARWORDS
 BASE (FOLDLO NBYTES BYTESPERWORD))))))

(\CLEARCELLS

  (LAMBDA (BASE NCELLS)
                                      (* bvm: "20-Feb-85 12:51")

    (while (IGEQ NCELLS (FOLDLO 32767 WORDSPERCELL))
           do                                                (* Keep the BLTs small.

                                                             See \CLEARWORDS)

           (.CLEARNWORDS. BASE 32768)
           (SETQ BASE (\ADDBASE BASE 32768))
           (SETQ NCELLS (IDIFFERENCE NCELLS (FOLDLO 32768 WORDSPERCELL))))
    (COND
       ((IGREATERP NCELLS 0)
        (SETQ NCELLS (UNFOLD NCELLS WORDSPERCELL))
        (.CLEARNWORDS. BASE NCELLS)))))
)
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS)
                                     (* Clear NWORDS words starting at base. Assumes NWORDS is smallp 
                                        and greater than zero. Compiler refuses to optimize out an 
                                        IGREATERP test here, so push back to caller)
                                     (\PUTBASE BASE (SUB1 NWORDS)
                                            0)
                                     (COND ((NEQ NWORDS 1)
                                            (\BLT BASE (\ADDBASE BASE 1)
                                                  (SUB1 NWORDS))))
                                     NIL))
)
)



(* "Obsolete:")


(DECLARE: EVAL@COMPILE DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE 

(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
                                  (\BLT (\ADDBASE DBASE DOFFSET)
                                        (\ADDBASE SBASE SOFFSET)
                                        NWORDS)))
)


(* END EXPORTED DEFINITIONS)

)
(DEFINEQ

(\MOVEWORDS

  (LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS)
               (* bvm: "15-JUN-82 13:56")

    (\BLT
 (\ADDBASE DBASE DOFFSET)
          (\ADDBASE SBASE SOFFSET)
          NWORDS)))

(\ZEROBYTES

  (LAMBDA (BASE FIRST LAST)
                                  (* bvm: "29-Jan-85 19:12")

    (\CLEARBYTES
 BASE FIRST (ADD1 (IDIFFERENCE LAST FIRST)))))

(\ZEROWORDS

  (LAMBDA (BASE ENDBASE)
                                     (* bvm: "29-Jan-85 12:54")

    (while (IGREATERP (\HILOC ENDBASE)
                  (\HILOC BASE))
           do
           (\CLEARWORDS
 BASE (IDIFFERENCE (SUB1 WORDSPERSEGMENT)
                                    (\LOLOC BASE)))
           (\PUTBASE (\VAG2 (\HILOC BASE)
                            (SUB1 WORDSPERSEGMENT))
                  0 0)                                       (* Done this way to avoid non-SMALLP 

                                                             arithmetic when (\LOLOC BASE) = 0)

           (SETQ BASE (\VAG2 (ADD1 (\HILOC BASE))
                             0)))
    (PROG ((DIF (IDIFFERENCE (\LOLOC ENDBASE)
                       (\LOLOC BASE))))
          (COND
             ((IGEQ DIF 0)
              (\PUTBASE BASE 0 0)
              (\CLEARWORDS
 (\ADDBASE BASE 1)
                     DIF))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DONTCOPY 

(ADDTOVAR INITVALUES
 (\AtomFrLst 0))

(ADDTOVAR INITPTRS
 (\OneCharAtomBase NIL)
                   (\SCRATCHSTRING))

(ADDTOVAR INEWCOMS
 (FNS FSETVAL SETPROPLIST PUTDEFN \BLT \ATOMCELL)
                   (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES)
                   (FNS COPYATOM INITATOMS))

(ADDTOVAR EXPANDMACROFNS
 SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL \PNAMECELL 
                               \PROPCELL \INDEXATOMPNAME)

(ADDTOVAR MKI.SUBFNS
 (\PARSE.NUMBER . NILL)
                     (\MKATOM.FULL . NILL)
                     (\ATOMDEFINDEX . I.ATOMNUMBER)
                     (\ATOMVALINDEX . I.ATOMNUMBER)
                     (\ATOMPROPINDEX . I.ATOMNUMBER)
                     (\ATOMPNAMEINDEX . I.ATOMNUMBER)
                     (SETQ.NOREF . SETQ)
                     (SETTOPVAL . I.FSETVAL))

(ADDTOVAR RD.SUBFNS
 (\PARSE.NUMBER . NILL)
                    (\ATOMDEFINDEX . VATOMNUMBER)
                    (\ATOMPROPINDEX . VATOMNUMBER)
                    (\ATOMVALINDEX . VATOMNUMBER)
                    (SETQ.NOREF . SETQ)
                    (\INDEXATOMPNAME . VATOM)
                    (\INDEXATOMVAL . VATOM)
                    (\INDEXATOMDEF . VATOM)
                    (\CREATE.SYMBOL . VNOSUCHATOM))

(ADDTOVAR RDCOMS
 (FNS COPYATOM UNCOPYATOM \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL GETDEFN \ATOMCELL)
                 (FNS LISTP)
                 (VARS (COPYATOMSTR)))

(ADDTOVAR RD.SUBFNS
 (\RPLPTR . VPUTBASEPTR))

(ADDTOVAR RDVALS
 (\AtomFrLst))
)

(PUTPROPS LLBASIC FILETYPE
 COMPILE-FILE)
(PUTPROPS LLBASIC COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (5782 8778 (LISTP 5792 . 6499) (LITATOM 6501 . 6744) (FIXP 6746 . 6985) (STRINGP 6987 . 
7245) (SMALLP 7247 . 7503) (NLISTP 7505 . 7720) (ARRAYP 7722 . 7978) (ATOM 7980 . 8198) (FLOATP 8200
 . 8456) (NUMBERP 8458 . 8610) (STACKP 8612 . 8776)) (11857 13895 (GETTOPVAL 11867 . 12030) (SETTOPVAL
 12032 . 12411) (FSETVAL 12413 . 12771) (\SETGLOBALVAL.UFN 12773 . 12947) (\SETFVAR.UFN 12949 . 13122)
 (GETPROPLIST 13124 . 13288) (\ATOMCELL 13290 . 13710) (SETPROPLIST 13712 . 13893)) (14750 28123 (
\MKATOM 14760 . 23145) (\CREATE.SYMBOL 23147 . 26470) (\MKATOM.FULL 26472 . 26966) (\INITATOMPAGE 
26968 . 28121)) (28124 33598 (MAPATOMS 28134 . 28445) (ATOMHASH#PROBES 28447 . 33596)) (33599 37060 (
INITATOMS 33609 . 35555) (COPYATOM 35557 . 36319) (UNCOPYATOM 36321 . 37058)) (37167 44200 (\DEFINEDP 
37177 . 37392) (PUTD 37394 . 38007) (\PUTD 38009 . 40976) (GETD 40978 . 41768) (PUTDEFN 41770 . 44034)
 (GETDEFN 44036 . 44198)) (53202 56266 (\RESETSYSTEMSTATE 53212 . 53373) (INITIALEVALQT 53375 . 55126)
 (SIMPLEPRINT 55128 . 56264)) (56358 57160 (PAGEFAULTS 56368 . 56555) (\SETTOTALTIME 56557 . 56977) (
\SERIALNUMBER 56979 . 57158)) (57222 61877 (\BLT 57232 . 58229) (\MOVEBYTES 58231 . 59608) (
\CLEARWORDS 59610 . 60423) (\CLEARBYTES 60425 . 61249) (\CLEARCELLS 61251 . 61875)) (63050 64391 (
\MOVEWORDS 63060 . 63265) (\ZEROBYTES 63267 . 63445) (\ZEROWORDS 63447 . 64389)))))
STOP