(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "18-Oct-86 12:43:57" {eris}<lispcore>sources>llbasic.\;67
 70146  

      |changes| |to:|  (records pnamecell)
                       (fns copyatom)

      |previous| |date:| "17-Oct-86 15:49:07" {eris}<lispcore>sources>llbasic.\;65)


; 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 floatp numberp stackp)
        (functions atom)
        (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)
              (coms (* \; "For MAKEINIT & TeleRaid")
                    (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 cl: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.))
              (coms (* \; "Obsolete")
                    (declare\: eval@compile dontcopy (export (macros \\movewords)))
                    (fns \\movewords \\zerobytes \\zerowords)))
        (localvars . t)
        (declare\: dontcopy (* \; "For MAKEINIT & TeleRaid")
               (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 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| typep\s)

    (\\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)))

(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)))
)
(definline atom
 (x) (or (null x)
                        (and (\\typemask.ufn x 8)
                             t)))

(declare\: dontcopy 
(* FOLLOWING DEFINITIONS EXPORTED)


(declare\: eval@compile 

(putprops check macro (args (cond ((and (boundp 'check)
                                        check)
                                   (cons 'progn (|for| i |in| args |collect|
                                                       (list 'or i (list 'raid
                                                                         (kwote (list '
                                                                                     |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 `(setq.noref \, (cadar x)
                                          \,
                                          (cadr x))))
       (putprops setxvar dmacro (x (or (and (eq (caar x)
                                                'quote)
                                            (litatom (cadar x)))
                                       (shouldnt))
                                   (globalvars \\valspace)
                                   (list 'setq.noref (cadar x)
                                         (cadr x)))))
(putprops setq.noref dmacro ((var val)
                             (\\putbaseptr (locf (|fetch| (litatom value)
                                                        |of|
                                                        'var))
                                    0 val)))
(progn (putprops ieq macro ((x y)
                            (ieqp x y)))
       (putprops ieq dmacro (= . eq)))
)
(settemplate 'spreadapply* '(functional .. eval))
(settemplate 'spreadapply '(functional eval . ppe))
(settemplate 'setq.noref '(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 `((opcodes atomcell.n \, (car ce))
                                                 \,
                                                 (car x)))
                                           (t 'ignoremacro))))

(defoptimizer getproplist
 (x) `(\\getbaseptr (\\propcell ,x)
                                      0))

(defoptimizer setproplist
 (atm lst) `(\\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.| g\o |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 '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.| i\f |found,| |returns| |number| |of| |probes| |needed| |to| |find| 

          |it,| \a |minimum| |of| |one.| i\f |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))))))))))
)



(* \; "For MAKEINIT & TeleRaid")


(defineq

(initatoms

  (lambda nil
                                                (* |bvm:| "30-Sep-86 22:59")


                                                  (* |;;| 

                                       "called only under MAKEINIT to initialize the making of atoms")

    (createpages |\\AtomHashTable| |\\AtomHTpages|)
    (setq \\scratchstring (allocstring \\pnamelimit))

                                                  (* \; "\\SCRATCHSTRING created in remote space simply to make renaming simple.  Could smash it to NIL inside init.sysout")

    (let ((base (|ffetch|
 (stringp
 base) |of|
 \\scratchstring))
          (offst (|ffetch|
 (stringp
 offst) |of|
 \\scratchstring)))
                                                             (* (createpages \\pncharsspace 1))

         (copyatom
 nil)                                      (* \; "NIL is atom 0")

         (copyatom
 'nobind)                                  (* \; "atom 1")

                                                             (* |;;| 

                            "Now make the single character atoms -- all thin chars except the digits")

         (|for|
 c |from|
 0 |to|
 255 |when|
 (or (ilessp c (charcode 0))
                                               (igreaterp c (charcode 9)))
            |do|
 (\\putbasebyte base offst c)
                 (\\mkatom
 base offst 1))
         (setq |\\OneCharAtomBase| (\\addbase \\atomspace 2))(* \; 

                                                             "= (CHARACTER 0) -- for FCHARACTER")

         (copyatom
 (function \\evalform))                    (* \; "atom 256-10+2 = 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)
                                                (* |Pavel| "18-Oct-86 00:39")


                                                  (* |;;| "this function is only for the use of MAKEINIT, which passes it a local atom to be translated into an atom in the remote sysout.")

    (allocal (let ((pkg (cl:symbol-package x)))
   (* \; 

                               "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world")

                  (|if|
 (neq pkg *interlisp-package*)
                      |then|
 
                     (* \; "Kludge time.  We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix")

                            (|if|
 (eq pkg *keyword-package*)
                                |then|
 (setq x (concat ":" x))
                              |elseif|
 (find-exact-symbol x *interlisp-package*)
                                |then|
 
           (* |;;| "Symbol is homed somewhere else but is accessible in Interlisp package.  These are symbols that are going to get moved from IL to CL when the sysout starts up, so no translation needed.  This is a messy test, which is why we test for Interlisp and keyword packages first.")

                              |elseif|
 (eq pkg *lisp-package*)
                                |then|
 
           (* |;;| 

                                          "Symbol lives in CL and not available in IL, so add prefix")

                                      (setq x (concat "CL::" x))
                              |elseif|
 (string-equal (cl:package-name pkg)
                                              "SYSTEM")
                                |then|
 
           (* |;;| 

                                                  "SYSTEM = SI package.  All internal for now.")

                                      (setq x (concat "SI::" x))
                              elseif
 (string-equal (cl:package-name pkg)
                                            "XEROX-COMMON-LISP")
                                then
 
             (* |;;| 

             "Make it internal.  The xcl-package stuff will export the right ones when it starts up.")

                                     (setq x (concat "XCL::" x))
                              elseif
 (string-equal (cl:package-name pkg)
                                            "COMPILER")
                                then
 
             (* |;;| 

        "Make it internal.  The compiler-package stuff will export the right ones when it starts up.")

                                     (setq x (concat "COMPILER::" x))
                              elseif
 (string-equal (cl:package-name pkg)
                                            "FASL")
                                then
 
             (* |;;| 

            "Make it internal.  The fasl-package stuff will export the right ones when it starts up.")

                                     (setq x (concat "FASL::" x))
                              |else|
 (help 
                              "Can only translate symbols in IL, CL, SI, COMPILER, FASL and keywords" 
                                           x)))))
    (let ((n (local (nchars x)))
          (base (|ffetch|
 (stringp
 base) |of|
 \\scratchstring))
          (offst (|ffetch|
 (stringp
 offst) |of|
 \\scratchstring)))

                                                  (* \; "\\SCRATCHSTRING is initialized in INITATOMS")

         (|for|
 i |from|
 1 |to|
 n |do|
 (\\putbasebyte base (local (iplus offst i -1))
                                              (local (nthcharcode x i))))
         (\\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 '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 '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 '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 cl: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 (cl:aref *package-from-index*
                                                             (fetch
 (pnamecell packageindex)
                                                                of
 datum))
                                                    (replace
 (pnamecell packageindex) of
 datum
                                                       with
 (if
 (null newvalue)
                                                                then
 *uninterned-package-index*
                                                              else
 (cl::package-index newvalue)))))))

(accessfns packageindex
 ((package (cl: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 'litatom))))
(putprops \\atomdefindex dmacro ((x)
                                 (\\loloc (\\dtest x 'litatom))))
(putprops \\atompnameindex dmacro ((x)
                                   (\\loloc (\\dtest x 'litatom))))
(putprops \\atompropindex dmacro ((x)
                                  (\\loloc (\\dtest x '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)
                     '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.|

          w\e |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| blt\s |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 uncopyatom \\mkatom gettopval getproplist settopval getdefn \\atomcell)
                 (fns listp)
                 (vars (copyatomstr)))

(addtovar rd.subfns
 (\\rplptr . vputbaseptr))

(addtovar rdvals
 (|\\AtomFrLst|))
)

(putprops llbasic filetype
 cl:compile-file)
(putprops llbasic copyright ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(declare\: dontcopy
  (filemap (nil (5914 8713 (listp 5924 . 6517) (litatom 6519 . 6839) (fixp 6841 . 7091) (stringp 7093 . 
7360) (smallp 7362 . 7627) (nlistp 7629 . 7850) (arrayp 7852 . 8117) (floatp 8119 . 8384) (numberp 
8386 . 8542) (stackp 8544 . 8711)) (11802 13904 (gettopval 11812 . 11978) (settopval 11980 . 12365) (
fsetval 12367 . 12734) (\\setglobalval.ufn 12736 . 12920) (\\setfvar.ufn 12922 . 13105) (getproplist 
13107 . 13275) (\\atomcell 13277 . 13710) (setproplist 13712 . 13902)) (14698 27816 (\\mkatom 14708 . 
22510) (\\create.symbol 22512 . 25950) (\\mkatom.full 25952 . 26507) (\\initatompage 26509 . 27814)) (
27817 33199 (mapatoms 27827 . 28148) (atomhash#probes 28150 . 33197)) (33241 40500 (initatoms 33251 . 
35829) (copyatom 35831 . 39750) (uncopyatom 39752 . 40498)) (40613 47427 (\\definedp 40623 . 40837) (
putd 40839 . 41390) (\\putd 41392 . 44343) (getd 44345 . 45034) (putdefn 45036 . 47258) (getdefn 47260
 . 47425)) (56691 59639 (\\resetsystemstate 56701 . 56867) (initialevalqt 56869 . 58499) (simpleprint 
58501 . 59637)) (59735 60511 (pagefaults 59745 . 59952) (\\settotaltime 59954 . 60319) (\\serialnumber
 60321 . 60509)) (60576 65554 (\\blt 60586 . 61505) (\\movebytes 61507 . 62998) (\\clearwords 63000 . 
63759) (\\clearbytes 63761 . 64580) (\\clearcells 64582 . 65552)) (66837 68331 (\\movewords 66847 . 
67060) (\\zerobytes 67062 . 67244) (\\zerowords 67246 . 68329)))))
stop