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

(filecreated "16-Oct-86 23:41:57" {eris}<lispcore>sources>aputdq.\;34
 28110  

      |previous| |date:| "13-Mar-86 12:59:04" {eris}<lispcore>sources>aputdq.\;33)


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

(prettycomprint aputdqcoms)

(rpaqq aputdqcoms
 
       ((fns greetfilename faulteval faultapply errorx)
        (fns smashfilecoms smashfilecomslst)
        (initvars (defaultregistry)
               (usergreetfiles)
               (loginhost/dir '{dsk}))
        (fns resetrestore resetvars resetsave resetvar)
        (fns loadup endloadup)
        (vars loadupdirectories)
        (alists (systeminitvars \\connected.directory dwimflg addspellflg filepkgflg buildmapflg 
                       updatemapflg defaultregistry defaultprintinghost directories usergreetfiles 
                       networkostypes ch.net.hint ch.default.domain ch.default.organization 
                       advisedfns lispusersdirectories displayfontdirectories displayfontextensions 
                       interpressfontdirectories pressfontwidthsfiles))
        (declare\: donteval@load docopy (p (setinterrupt 4 'reset)
                                           (setinterrupt 20 'control-t))
               (p (dummydef (addstats *)
                         (statinit nill)
                         (lispxwatch nill)
                         (clbufs nill)
                         (findfile infilep)
                         (filemap *)
                         (virginfn getd)
                         (mkswapp nill))
                  (dummydef (usernumber zero)
                         (hostnumber zero)
                         (hostname nill)
                         (trapcount zero))
                  (dummydef (* quote)
                         (getp getprop)
                         (declare quote)
                         (frplnode2 rplnode2)
                         (displaytermp true)
                         (minfs evq)
                         (frplaca rplaca)
                         (frplacd rplacd)
                         (misspelled? nill)
                         (undosave nill)
                         (setlinelength zero)
                         (dobe nill)
                         (relink nill)
                         (put putprop)
                         (/put putprop)
                         (mkswap evq)))
               (addvars (sysfiles)
                      (lispxhistory)
                      (linkedfns))
               (vars (shallowflg)
                     (spaghettiflg t)
                     (widepaperflg t)
                     (clearstklst t)
                     (syshasharray (hasharray 50))
                     (displaytermflg t)
                     (\#undosaves)
                     (nlama)
                     (nlaml)
                     (lams)
                     (evalqtforms)
                     (ttylinelength 82)
                     (compile.ext 'dcom)
                     (sysout.ext 'sysout)
                     (hostname)
                     (systemtype (systemtype)))
               (p (gcgag t)))
        (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama resetsave 
                                                                                      resetvars)
                                                                             (nlaml resetvar)
                                                                             (lama)))))
(defineq

(greetfilename

  (lambda (user)
                                             (* |lmm| "12-Apr-85 18:11")

                                                             (* |Returns| |name| |of| |an| 

                                                             |existing| |greeting| |file,| |or| nil)

    (declare
 (globalvars usergreetfiles loginhost/dir compile.ext))
    (selectq user
        (t (or (infilep '{dsk}init.lisp)
               (|bind|
 file |while|
 (setq file (promptforword '
                   "Please enter name of system init file
(e.g. {server}<directory>INIT.extension): ")) |until|
 (setq file (infilep (mkatom file)))
                  |finally|
 (return file))))
        (nil)
        (cond
           ((listp usergreetfiles)
            (prog ((pos (and defaultregistry (strpos '\. (setq user (u-case user))))))
                  (cond
                     ((and pos (strequal (substring user (add1 pos)
                                                -1)
                                      (mkstring defaultregistry)))
                      (setq user (substring user 1 (sub1 pos)))))
                  (return (|for|
 d |in|
 (cond
                                           ((listp (car usergreetfiles))
                                            usergreetfiles)
                                           (t (cons usergreetfiles)))
                             |when|
 (setq d (infilep (pack (subpair '(user com) (list user 
                                                                                      compile.ext)
                                                                  d)))) |do|
 (return d)))))))))

(faulteval

  (nlambda faultx
                                            (* |lmm| "16-MAY-80 11:57")

    (raid faultx)))

(faultapply

  (lambda (faultfn faultargs)
                                (* |lmm| "16-MAY-80 11:58")

    (raid faultfn)))

(errorx

  (lambda (erxm)
                                             (* |lmm| "16-MAY-80 11:58")

    (raid erxm)))
)
(defineq

(smashfilecoms

  (lambda (file)
                                             (* |JonL| " 8-Jun-84 10:43")

                                                             (* |dummy| |definition| |for| aputdq)

    (prog ((filecoms (pack (list file 'coms))))
          (cond
             ((boundp filecoms)
          
          (* |Already| |loaded,| |but| |may| |want| |to| |clobber| |its| fns\, vars\, 

          |and| blocks e.g. misc\, basic.)


              (smashfilecomslst
 (getatomval filecoms))
              (set filecoms 'nobind))))))

(smashfilecomslst

  (lambda (coms)
                                             (* |lmm| "11-MAR-83 13:17")

    (mapc coms (function (lambda (com)
                           (prog (name)
                                 (and (eq (cadr com)
                                          '*)
                                      (litatom (caddr com))
                                      (setq name (caddr com)))
                                 (selectq (car com)
                                     (coms (smashfilecomslst
 (cond
                                                                (name (getatomval name))
                                                                (t (cdr com)))))
                                     (filevars (setq name (cond
                                                             ((eq (cadr com)
                                                                  '*)
          
          (* |if| |caddr| |is| \a |litatom,| |name| |was| |set| |to| |it| |above.|

          |if| |caddr| |is| |not,| |dangerous| |to| |evaluate| |the| |form,| |so| |punt|)


                                                              (getatomval name))
                                                             (t (cdr com)))))
                                     ((prop ifprop) 
                                          (cond
                                             ((and (eq (caddr com)
                                                       '*)
                                                   (litatom (cadddr com)))
                                              (setq name (cadddr com)))))
                                     nil)
                                 (cond
                                    ((and name (litatom name))
                                     (set name 'nobind)))))))))
)

(rpaq? defaultregistry
 )

(rpaq? usergreetfiles
 )

(rpaq? loginhost/dir
 '{dsk})
(defineq

(resetrestore

  (lambda (resetvarslst0 resetstate)
                         (* |wt:| "15-MAR-78 14:25")

          
          (* |Goes| |down| resetvarslst |doing| |restoration| |until| |it| |gets| |to| 

          nil |or| resetvarslst0. resetstate |is| |either| nil\, error\, |or| reset\, 

          |depending| |on| |whether| |restoration| |is| |at| |normal|

          (|successful|) |completion| |of| \a resetlst\, |following| |an| |error| |or| 

          |control-E,| |or| |following| \a |control-D|)


    (prog (resetz oldvalue)
      lp  (cond
             ((and resetvarslst (not (tailp resetvarslst resetvarslst0)))
              (setq resetz (car resetvarslst))
              (setq resetvarslst (cdr resetvarslst))
              (cond
                 ((listp (car resetz))
                  (setq oldvalue (cond
                                    ((cdr resetz)
          
          (* |occurs| |for| |RESETSAVE's| |when| |second| |aagument| |is| |specified.|

          i\n |this| |case,| (cadr resetz) |is| |the| |value| |of| |the| |saving| |form,| 

          |i.e.| |the| |first| |argument| |to| resetsave.)


                                     (cadr resetz))
                                    (t (cadar resetz))))
                  (apply (caar resetz)
                         (cdar resetz)))
                 (t (settopval (car resetz)
                           (cdr resetz))))
              (go lp))))))

(resetvars

  (nlambda resetx
                                            (* |wt:| "14-JAN-80 23:29")

    (prog ((resetw (setq resetvarslst (prog ((resetz resetvarslst))
                                            (mapc (car resetx)
                                                  (function (lambda (resety)
                                                              (setq resetz
                                                               (cons (cond
                                                                        ((listp resety)
                                                                         (cons (car resety)
                                                                               (gettopval
                                                                                (car resety))))
                                                                        (t (cons resety (gettopval
                                                                                         resety))))
                                                                     resetz)))))
                                            (return resetz))))
           resety)
          (setq resety resetvarslst)
          (return (car (or (prog1 (xnlsetq (progn (mapc (car resetx)
                                                        (function (lambda (resety)
                                                                    (cond
                                                                       ((listp resety)
                                                                        (settopval
                                                                         (car resety)
                                                                         (apply 'prog1 (cdr resety)
                                                                                'internal)))
                                                                       (t (settopval resety))))))
                                                  (apply 'prog (cons nil (cdr resetx))
                                                         'internal))
                                         internal)
                                  (mapc (car resetx)
                                        (function (lambda (z)
                                                    (settopval (caar resetw)
                                                           (cdar resetw))
                                                    (setq resetw (cdr resetw)))))
                                  (cond
                                     ((eq resety resetvarslst)
                                      (setq resetvarslst resetw))
                                     ((not (tailp resetvarslst resety))
          
          (* |some| |resetsaves| |may| |hae| |been| |performed| |inside| |of| |the| 

          |resetvars.| |these| |should| not |be| |ndone| |until| |the| |corresonding| 

          |resetlst| |is| |exited| (|they| |wouldnt| |be| |in| |shallow| |system| |since| 

          |restvarsis| |simply| \a |prog|) |therefore| |the| |section| |of| |resetvarlst| 

          |corresponding| |to| |the| |variable| |rebindings| |must| |be| |spliced| |out|)

          
          (* |the| |reason| |for| |the| tailp |is| |that| |if| |resetvarslst| |has| |for| 

          |some| |reason| |already| |been| |stripped| |back| |earlier| |than| |resety,| 

          |dont| |want| |to| |do| |the| |nleft/rplacd.|

          (|in| |fact| |nleft| |would| |generate| |an| |error|)\.

          |one| |can| |think| |of| |this| |as| |analaogical| |to| |the| |code| |in| 

          |resetrestore,| |where| |resetvarslst| |is| |walked| |down| |until| |it| |is| 

          \a |tail| |of| |resetvarslst0.|)

          
          (* |reason| |for| tailp |is| |to| |parallel| |the| |code| |in| |resetrestore,| 

          |where| |resetvarslst| |is| |processed| |until| |it| |is| \a |tail| |of| 

          |resetvarlst0.| |we| |are| |trying| |to| |avoid| |the| |situation| |where| 

          |resetvarslst| |has| |for| |some| |reason| |been| |stripped| |back| |to| 

          |before| |resety.| |note| |that| |if| |for| |some| |reason| |resetvarslst| |is| 

          |not| \a |tail| |of| |resety,| |but| |resety| |is| |not| \a |tail| |of| 

          |resetvarslst,| |then| |nleft| |will| |generate| |an| |error.|

          |this| |should| |not| |happen| |since| |things| |are| |supposed| |to| |be| 

          |taken| |off| |only| |in| |the| |order| |they| |were| |put| |on.|

          |if| |this| |turns| |out| |to| |be| \a |problem,| |we| |can| |undo| |things| 

          |on| |resetvarslst| |by| |smashing| |them| |and| |leaving| |them| |alone.|)


                                      (rplacd (nleft resetvarslst 1 resety)
                                             resetw))))
                           (error!)))))))

(resetsave

  (nlambda resetx
                                            (* |wt:| "23-JUL-79 21:08")

          
          (* |for| |use| |under| \a resetlst. i\f resetx |is| |atmic,| |like| resetvar\, 

          |otherwise| |like| resetform\, |i.e.| |performs| |the| |resetting| |and| 

          |saving| |associated| |with| |these| |functions.|

          |The| |restoration| |aad| |errorset| |protectionis| |done| |by| resetlst.

          |Note| |that| |its| |value| |is| |not| |any| |particularly| |useful| 

          |quanitty.| |When| |used| \a |la| resetform\, |can| |take| \a |second| 

          |argument| |whose| |value| (|computed| |before| |firt| |argument|) |is| 

          |restoration| |form,| |e.g.| (resetsave (setsepr --)

          (list (quote setsepr) (getsepr))) (resetsave nil |form|) |means| |just| |add| 

          |value| |of| |form| |to| resetvarlst>)


    (setq resetvarslst (cons (cond
                                ((and (car resetx)
                                      (atom (car resetx)))
                                 (prog1 (cons (car resetx)
                                              (gettopval (car resetx)))
                                        (settopval (car resetx)
                                               (eval (cadr resetx)
                                                     'internal))))
                                ((cdr resetx)
          
          (* cadr |of| |the| |entry| |put| |on| |resetvarslst| |is| |the| |value| |of| 

          |the| |saving| |form.| |The| |variable| oldvalue |is| |bound| |to| |this| 

          |value| |during| |restoration.| |This| |makes| |it| |more| |convenient| |for| 

          |the| |estoration| |to| |be| |conditional,| |e.g.|

          |the| |user| |can| |perform| (resetsave (foo |mumble|)

          (quote (and |pred| (fie oldvalue)))))


                                 (list (eval (cadr resetx))
                                       (eval (car resetx))))
                                (t (list (list (cond
                                                  ((eq (caar resetx)
                                                       'setq)
                                                   (car (caddar resetx)))
                                                  (t (caar resetx)))
                                               (eval (car resetx))))))
                             resetvarslst))))

(resetvar

  (nlambda (resetx resety resetz)
                            (* |wt:| "23-JUL-79 21:09")

    (prog (macrox macroy)
          
          (* |Permits| |evaluation| |of| \a |form| |while| |resetting| \a |top| |level| 

          |variable,| |and| |provides| |for| |the| |variable| |to| |be| |automatcally| 

          |restored| |after| |valuation.| i\n |this| |way,| |the| |user| |pays| |when| 

          |he| |wants| |to| |'rebind'| \a |globalvariable,| |but| |does| |not| |have| 

          |to| |pay| |for| |the| |possiblity,| |as| |would| |be| |the| |case| |if| 

          |variables| |such| |as| dfnflg\, lispxhistory\, |etc.|

          |were| |not| |global,| |i.e.| |were| |looked| |up.|

          i\n |the| |event| |of| \a |control-D,| |or| |control-C| |reenter,| |the| 

          |variabes| |will| |still| |be| |restored| |by| evalqt.

          |Note| |that| stkeval\s |will| |not| |do| |the| |right| \t |on| |variables| 

          |reset| |by| resetvar.)


          (setq macrox (setq resetvarslst (cons (cons resetx (gettopval resetx))
                                                resetvarslst)))
          (setq macroy (errorset (list 'progn (list 'settopval (list 'quote resetx)
                                                    resety)
                                       resetz)
                              'internal))
          (settopval (caar macrox)
                 (cdar macrox))
          (setq resetvarslst (cdr macrox))
          (cond
             (macroy (return (car macroy))))
          (error!))))
)
(defineq

(loadup

  (lambda (option/files)
                                     (* |jds| "13-Mar-86 12:58")

    (selectq option/files
        ((nil huge) 
             (setqq compile.ext dcom)
             (|while|
 bootloadedfiles |do|
 (|pushnew|
 sysfiles (|pop|
 bootloadedfiles)))
             (loadup
 '(acode machineindependent postloadup))
             (loadup
 '(bsp dpupftp))
          
          (* |Load| |these| |now| |to| |speed| |up| |the| |rest| |of| |the| |loading|)


             (loadup
 '(afont))
             (loadup
 '(edit wedit pretty dsprintdef newprintdef comment advise loadfns dmisc dfile))
                                                             (* dmisc |needs| |to| |come| |before| 

                                                             dfile)

             (loadup
 '(compatibility break filepkg resource))
             (loadup
 '(macros dlap bytecompiler compile))
             (loadup
 '(hist undo spell dwim wtfix clisp dwimify clispify record assist helpdl))
             (loadup
 '(common))
             (loadup
 '(hprint macroaux addarith))
             (loadup
 '(msanalyze msparse masterscope))
             (dwim 'c)
             (compilemode 'd)
             (loadup
 '(aarith))
             (loadup
 '(adisplay hldisplay menu window attachedwindow wbreak xxgeom xxfill))
             (loadup
 '(dexec inspect))
             (loadup
 '(dedit ttyin))
             (loadup
 '(diskdlion doveinputoutput dovedisk dovedisplay dovemisc doveether dovefloppy 
                             localfile dskdisplay))
             (loadup
 '(10mbdriver llns trserver))
             (loadup
 '(brkdwn match))
             (loadup
 '(llfcompile))
             (loadup
 '(spp courier nsprint clearinghouse nsfiling hardcopy press pupprint interpress 
                           floppy))
             (loadup
 '(idler)))
        (cond
           ((listp option/files)
          
          (* resetvar |just| |in| |case| |some| |sub-loading| |wants| |to| "reach out" 

          |to| |other| |files|)


            (|for|
 x |in|
 option/files
               |do|
 (or (fmemb x sysfiles)
                        (resetvar
 directories loadupdirectories
                         (dofilesload (list '(sysload from valueof loadupdirectories) x))))
                    (smashfilecoms
 x)))
           (t (help "BAD LOADUP OPTION" option/files))))))

(endloadup

  (lambda nil
                                                (* |lmm| "29-Nov-84 16:39")

          
          (* |set| |up| |for| nonet |configuration;|

          |sites| |with| |ethernet| |can| |load| |in| |init| |from| |other| |places|)

          
          (* * |All| |records| |existing| |at| |this| |point| |in| |time| |have| |been| 

          |loaded| |as| |part| |of| |the| |system.|)


    (mapc userreclst (function (lambda (r)
                                 (recordpriority r 'system))))
    (mapc systeminitvars (function (lambda (x)
                                     (settopval (car x)
                                            (copy (cdr x))))))))
)

(rpaqq loadupdirectories
 ({eris}<lispcore>sources> {eris}<lispcore>library> {eris}<lispusers>))

(addtovar systeminitvars
 (\\connected.directory . {dsk})
                         (dwimflg . t)
                         (addspellflg . t)
                         (filepkgflg . t)
                         (buildmapflg . t)
                         (updatemapflg . t)
                         (defaultregistry)
                         (defaultprintinghost)
                         (directories)
                         (usergreetfiles)
                         (networkostypes)
                         (ch.net.hint)
                         (ch.default.domain)
                         (ch.default.organization)
                         (advisedfns)
                         (lispusersdirectories {dsk})
                         (displayfontdirectories {dsk})
                         (displayfontextensions displayfont)
                         (interpressfontdirectories {dsk})
                         (pressfontwidthsfiles {dsk}fonts.widths))
(declare\: donteval@load docopy 
(setinterrupt 4 'reset)
(setinterrupt 20 'control-t)

(dummydef (addstats *)
       (statinit nill)
       (lispxwatch nill)
       (clbufs nill)
       (findfile infilep)
       (filemap *)
       (virginfn getd)
       (mkswapp nill))
(dummydef (usernumber zero)
       (hostnumber zero)
       (hostname nill)
       (trapcount zero))
(dummydef (* quote)
       (getp getprop)
       (declare quote)
       (frplnode2 rplnode2)
       (displaytermp true)
       (minfs evq)
       (frplaca rplaca)
       (frplacd rplacd)
       (misspelled? nill)
       (undosave nill)
       (setlinelength zero)
       (dobe nill)
       (relink nill)
       (put putprop)
       (/put putprop)
       (mkswap evq))


(addtovar sysfiles
 )

(addtovar lispxhistory
 )

(addtovar linkedfns
 )


(rpaqq shallowflg
 nil)

(rpaqq spaghettiflg
 t)

(rpaqq widepaperflg
 t)

(rpaqq clearstklst
 t)

(rpaq syshasharray
 (hasharray 50))

(rpaqq displaytermflg
 t)

(rpaqq \#undosaves
 nil)

(rpaqq nlama
 nil)

(rpaqq nlaml
 nil)

(rpaqq lams
 nil)

(rpaqq evalqtforms
 nil)

(rpaqq ttylinelength
 82)

(rpaqq compile.ext
 dcom)

(rpaqq sysout.ext
 sysout)

(rpaqq hostname
 nil)

(rpaq systemtype
 (systemtype))

(gcgag t)
)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 resetsave resetvars)

(addtovar nlaml
 resetvar)

(addtovar lama
 )
)
(prettycomprint aputdqcoms)

(rpaqq aputdqcoms
 
       ((fns greetfilename faulteval faultapply errorx)
        (fns smashfilecoms smashfilecomslst)
        (initvars (defaultregistry)
               (usergreetfiles)
               (loginhost/dir '{dsk}))
        (fns resetrestore resetvars resetsave resetvar)
        (fns loadup endloadup)
        (vars loadupdirectories)
        (alists (systeminitvars \\connected.directory dwimflg addspellflg filepkgflg buildmapflg 
                       updatemapflg defaultregistry defaultprintinghost directories usergreetfiles 
                       networkostypes ch.net.hint ch.default.domain ch.default.organization 
                       advisedfns lispusersdirectories displayfontdirectories displayfontextensions 
                       interpressfontdirectories pressfontwidthsfiles))
        (declare\: donteval@load docopy (p (setinterrupt 4 'reset)
                                           (setinterrupt 20 'control-t))
               (p (dummydef (addstats *)
                         (statinit nill)
                         (lispxwatch nill)
                         (clbufs nill)
                         (findfile infilep)
                         (filemap *)
                         (virginfn getd)
                         (mkswapp nill))
                  (dummydef (usernumber zero)
                         (hostnumber zero)
                         (hostname nill)
                         (trapcount zero))
                  (dummydef (* quote)
                         (getp getprop)
                         (declare quote)
                         (frplnode2 rplnode2)
                         (displaytermp true)
                         (minfs evq)
                         (frplaca rplaca)
                         (frplacd rplacd)
                         (misspelled? nill)
                         (undosave nill)
                         (setlinelength zero)
                         (dobe nill)
                         (relink nill)
                         (put putprop)
                         (/put putprop)
                         (mkswap evq)))
               (addvars (sysfiles)
                      (lispxhistory)
                      (linkedfns))
               (vars (shallowflg)
                     (spaghettiflg t)
                     (widepaperflg t)
                     (clearstklst t)
                     (syshasharray (hasharray 50))
                     (displaytermflg t)
                     (\#undosaves)
                     (nlama)
                     (nlaml)
                     (lams)
                     (evalqtforms)
                     (ttylinelength 82)
                     (compile.ext 'dcom)
                     (sysout.ext 'sysout)
                     (hostname)
                     (systemtype (systemtype)))
               (p (gcgag t)))
        (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama resetsave 
                                                                                      resetvars 
                                                                                      faulteval)
                                                                             (nlaml resetvar)
                                                                             (lama)))))
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 resetsave resetvars faulteval)

(addtovar nlaml
 resetvar)

(addtovar lama
 )
)
(putprops aputdq copyright ("Xerox Corporation" 1981 1982 1983 1984 1985 1986))
(declare\: dontcopy
  (filemap (nil (3574 5681 (greetfilename 3584 . 5283) (faulteval 5285 . 5416) (faultapply 5418 . 5551) 
(errorx 5553 . 5679)) (5682 8121 (smashfilecoms 5692 . 6258) (smashfilecomslst 6260 . 8119)) (8215 
18771 (resetrestore 8225 . 9690) (resetvars 9692 . 14685) (resetsave 14687 . 17171) (resetvar 17173 . 
18769)) (18772 21975 (loadup 18782 . 21266) (endloadup 21268 . 21973)))))
stop