Return to toplevel.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl

Annotation of 42BSD/ucb/lisp/pearl/toplevel.l, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; toplevel.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ;  Franz and UCI Lisp top level functions 
        !             3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             4: ; Copyright (c) 1983 ,  The Regents of the University of California.
        !             5: ; All rights reserved.  
        !             6: ; Authors: Joseph Faletti and Michael Deering and John Foderaro.
        !             7: 
        !             8: ;-------------------------------------------------------------------------
        !             9: ;  Top level functions for PEARL               Joe Faletti, December 1981
        !            10: ;      modified from
        !            11: ;  Top level function for franz                        jkf, march 1980
        !            12: ;
        !            13: ; The following function contains the top-level read, eval, print 
        !            14: ; loop.  With the help of the usual error handling functions, 
        !            15: ; pearl-break-err-handler and  debug-err-handler,  pearl-top-level provides
        !            16: ; a reasonable environment for working with PEARL.  
        !            17: ; 
        !            18: 
        !            19: (defvar \$ldprint)
        !            20: 
        !            21: ; Handle ^C with fixit.
        !            22: (de pearl:int-serv (x)
        !            23:   (fixit nil))
        !            24: 
        !            25: ; Before Opus 38.31:
        !            26: ; (setq pearl-title (concat " plus PEARL " (status ctime)))
        !            27: ; Moved to franz.l:
        !            28: ; (setq pearl-title (concat " plus PEARL " (time-string)))
        !            29: 
        !            30: (de read-in-initprl-file ()
        !            31:   (setq break-level-count 0    ; do this in case break
        !            32:        debug-level-count 0)   ; occurs during readin
        !            33:   (*catch '(break-catch top-level-catch)
        !            34:          (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
        !            35:               ; prevent warnings (from setdbsize in particular).
        !            36:               (*warn* nil *warn*)
        !            37:               (\$ldprint nil \$ldprint))       ; prevent messages
        !            38:              ((null dirs))
        !            39:              (cond ((do ((name '(".init.prl" "init.prl") (cdr name)))
        !            40:                         ((null name))
        !            41:                         (cond ((do ((ext '(".o" ".l" "") (cdr ext))
        !            42:                                     (file))
        !            43:                                    ((null ext))
        !            44:                                    (cond ((probef
        !            45:                                            (setq file (concat (car dirs)
        !            46:                                                               "/"
        !            47:                                                               (car name)
        !            48:                                                               (car ext))))
        !            49:                                           (cond ((atom (errset (load file)))
        !            50:                                                  (patom
        !            51:                                                   "Error loading init.prl file ")
        !            52:                                                  (print file)
        !            53:                                                  (terpr)
        !            54:                                                  (return 'error)))
        !            55:                                           (return t))))
        !            56:                                (return t))))
        !            57:                     (return t))))))
        !            58: 
        !            59: (de read-in-startprl-file ()
        !            60:   (setq break-level-count 0    ; do this in case break
        !            61:        debug-level-count 0)   ; occurs during readin
        !            62:   (*catch '(break-catch top-level-catch)
        !            63:          (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
        !            64:               (\$ldprint nil \$ldprint))       ; prevent messages
        !            65:              ((null dirs))
        !            66:              (cond ((do ((name '(".start.prl" "start.prl") (cdr name)))
        !            67:                         ((null name))
        !            68:                         (cond ((do ((ext '(".o" ".l" "") (cdr ext))
        !            69:                                     (file))
        !            70:                                    ((null ext))
        !            71:                                    (cond ((probef
        !            72:                                            (setq file (concat (car dirs)
        !            73:                                                               "/"
        !            74:                                                               (car name)
        !            75:                                                               (car ext))))
        !            76:                                           (cond ((atom (errset (load file)))
        !            77:                                                  (patom
        !            78:                                                   "Error loading start.prl file ")
        !            79:                                                  (print file)
        !            80:                                                  (terpr)
        !            81:                                                  (return 'error)))
        !            82:                                           (return t))))
        !            83:                                (return t))))
        !            84:                     (return t))))))
        !            85: 
        !            86: ; For the implementor who wishes to dump a PEARL.
        !            87: (df savepearl (name)
        !            88:   (sstatus ignoreeof nil)     ; to undo ~/.lisprc
        !            89:   (setq franz-not-virgin nil)
        !            90:   (aliasdef 'top-level 'pearl-top-level-init)
        !            91:   (setq \$gcprint nil)
        !            92:   (gc)                 ; garbage collect before dumping lisp
        !            93:   (cond (name (eval (list 'dumplisp (car name))))
        !            94:        ( t (dumplisp pearl)))
        !            95:   t)
        !            96: 
        !            97: ; For the user who wishes to dump a PEARL that starts with .init.prl.
        !            98: (de savefresh n
        !            99:   (prog (name)
        !           100:        ;   (INITFN 'STARTUPPEARL)
        !           101:        (setq franz-not-virgin nil)
        !           102:        (aliasdef 'top-level 'pearl-top-level-init)
        !           103:        (setq \$gcprint nil)
        !           104:        (gc)                    ; garbage collect before dumping lisp
        !           105:        (cond ((\=& n 1) (setq name (arg 1)))
        !           106:              ((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
        !           107:              ( t (setq name 'pearl)))
        !           108:        (eval (list 'dumplisp name))
        !           109:        (return t)))
        !           110: 
        !           111: ; For the user who wishes to dump a PEARL that continues with the
        !           112: ;     read-eval-print loop.
        !           113: (de savecontinue n
        !           114:   (prog (name)
        !           115:        ;   (INITFN 'PEARL-REP-LOOP)
        !           116:        (aliasdef 'top-level 'pearl-top-level)
        !           117:        (setq \$gcprint nil)
        !           118:        (gc)                    ; garbage collect before dumping lisp
        !           119:        (cond ((\=& n 1) (setq name (arg 1)))
        !           120:              ((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
        !           121:              ( t (setq name 'pearl)))
        !           122:        (eval (list 'dumplisp name))
        !           123:        (return t)))
        !           124: 
        !           125: (de pearlreploop ()
        !           126:   (prog (*pval*)
        !           127:        *pearlloop*
        !           128:        (terpri)
        !           129:        (and *printhistorynumber*
        !           130:             (patom (1+ *historynumber*)))
        !           131:        (patom *pearlprompt*)
        !           132:        (setq *readlinechanged* nil)
        !           133:        (cond ((eq (unbound)
        !           134:                   (setq *pval*
        !           135:                         (car (errset (eval (addhistory (read)))))))
        !           136:               (rplacx (\\ *historynumber* *historysize*)
        !           137:                       *histval*
        !           138:                       (unbound))
        !           139:               (prin 'unbound))
        !           140:              ( t (rplacx (\\ *historynumber* *historysize*)
        !           141:                          *histval*
        !           142:                          *pval*)
        !           143:                  (pearlprintfn  *pval*)))
        !           144:        (go *pearlloop*)))
        !           145:  
        !           146: (de pearl ()
        !           147:   (read-in-initprl-file)
        !           148:   (cond ((not (boundp '*db1size*))
        !           149:         (setdbsize 7.)))
        !           150:   (cond ((not (boundp '*db*))
        !           151:         (builddb *maindb*)
        !           152:         (setq *db* *maindb*)))
        !           153:   (cond ((not (boundp '*pearlprompt*))
        !           154:         (setq *pearlprompt* '|pearl> |))
        !           155:        ((null *pearlprompt*)
        !           156:         (setq *pearlprompt* '|-> |)))
        !           157:   (cond ((not (boundp '*historysize*))
        !           158:         (setq *historysize* 64.)))
        !           159:   (setq *historynumber* -1.)
        !           160:   (setq *history* (makhunk *historysize*))
        !           161:   (setq *histval* (makhunk *historysize*))
        !           162:   (read-in-startprl-file)
        !           163:   (terpri)
        !           164:   (pearlreploop))
        !           165:  
        !           166: (de initpearl ()
        !           167:   (cond ((not (boundp '*db1size*))
        !           168:         (setdbsize 7.)))
        !           169:   (cond ((not (boundp '*db*))
        !           170:         (builddb *maindb*)
        !           171:         (setq *db* *maindb*))))
        !           172: 
        !           173: (de pearl-top-level-init ()
        !           174:   (aliasdef 'reset 'franz-reset)
        !           175:   (aliasdef 'top-level 'pearl-top-level)
        !           176:   (signal 2 'pearl:int-serv)
        !           177:   (*catch '(top-level-catch break-catch)
        !           178:          (cond ((or (not (boundp 'franz-not-virgin))
        !           179:                     (null franz-not-virgin))
        !           180:                 (setq franz-not-virgin t
        !           181:                       + nil ++ nil +++ nil
        !           182:                       * nil ** nil *** nil)
        !           183:                 ; This is changed because fixit is included now.
        !           184:                 ;         (setq ER%tpl 'pearl-break-err-handler)
        !           185:                 (setq ER%tpl 'fixit)
        !           186:                 (setq ER%brk 'fixit)
        !           187:                 (setq ER%err 'fixit)
        !           188:                 
        !           189:                 ; The rest of the code should be within this
        !           190:                 ;     cond if autorunlisp existed
        !           191:                 ;          (cond ((not (autorunlisp))))
        !           192:                 ;
        !           193:                 (patom (status version))
        !           194:                 (cond ((boundp 'franz-minor-version-number)
        !           195:                        (patom franz-minor-version-number)))
        !           196:                 (patom pearl-title)
        !           197:                 (terpr)
        !           198:                 (cond (*firststartup* (setq *firststartup* nil)
        !           199:                                       (read-in-initprl-file)))
        !           200:                 (or *pearlprompt*
        !           201:                     (setq *pearlprompt* '|-> |))
        !           202:                 (and (not (\=& 64 *historysize*))
        !           203:                      (setq *history* (makhunk *historysize*))
        !           204:                      (setq *histval* (makhunk *historysize*)))
        !           205:                 (read-in-startprl-file))))
        !           206:   (reset))
        !           207: 
        !           208: (de pearl-top-level ()
        !           209:   ; loop forever
        !           210:   (do ((+*) (-) (retval))
        !           211:       (nil)
        !           212:       (setq retval
        !           213:            (*catch
        !           214:             '(top-level-catch break-catch)
        !           215:             ; begin or return to top level
        !           216:             (progn
        !           217:              (setq debug-level-count 0   break-level-count 0
        !           218:                    evalhook nil          funcallhook nil)
        !           219:              (cond (tpl-errlist (mapc 'eval tpl-errlist)))
        !           220:              (do ((^w nil nil))
        !           221:                  (nil)
        !           222:                  (cond (user-top-level (funcall user-top-level))
        !           223:                        ( t ; Print prompt.
        !           224:                            (and *printhistorynumber*
        !           225:                                 (patom (1+ *historynumber*)))
        !           226:                            (patom *pearlprompt*)
        !           227:                            (setq *readlinechanged* nil)
        !           228:                            
        !           229:                            (cond ((eq top-level-eof
        !           230:                                       ; read and add to history.
        !           231:                                       (setq - 
        !           232:                                             (car (errset
        !           233:                                                   (addhistory
        !           234:                                                    (read nil
        !           235:                                                          top-level-eof))))))
        !           236:                                   (cond ((not (status isatty))
        !           237:                                          (exit)))
        !           238:                                   (cond ((null (status ignoreeof))
        !           239:                                          (terpr)
        !           240:                                          (print 'Goodbye)
        !           241:                                          (terpr)
        !           242:                                          (exit))
        !           243:                                         ( t (terpr)
        !           244:                                             (setq - ''EOF)))))
        !           245:                            ; Eval and story result in history.
        !           246:                            (setq +* (eval -))
        !           247:                            (rplacx (\\ *historynumber* *historysize*)
        !           248:                                    *histval*
        !           249:                                    +*)
        !           250:                            ; update list of old forms
        !           251:                            (let ((val -))
        !           252:                                 (let ((o+ +) (o++ ++))
        !           253:                                      (setq +   val
        !           254:                                            ++  o+
        !           255:                                            +++ o++)))
        !           256:                            ; update list of old values
        !           257:                            (let ((val +*))
        !           258:                                 (let ((o* *) (o** **))
        !           259:                                      (setq *   val
        !           260:                                            **  o*
        !           261:                                            *** o**)))
        !           262:                            ; Don't print *invisible*.
        !           263:                            (and (neq '*invisible* +*)
        !           264:                                 (pearlprintfn +*))
        !           265:                            (terpr))))
        !           266:              (terpr)
        !           267:              (patom "[Return to top level]")
        !           268:              (terpr)
        !           269:              (cond ((eq 'reset retval) (old-reset-function))))))))
        !           270: 
        !           271: ; this is the break handler, it should be tied to 
        !           272: ; ER%tpl always.
        !           273: ; it is entered if there is an error which no one wants to handle.
        !           274: ; We loop forever, printing out our error level until someone
        !           275: ; types a ^D which goes to the next break level above us (or the 
        !           276: ; top-level if there are no break levels above us.)
        !           277: ; a (return n) will return that value to the error message
        !           278: ; which called us, if that is possible (that is if the error is
        !           279: ; continuable)
        !           280: ;
        !           281: (def pearl-break-err-handler 
        !           282:   (lexpr
        !           283:    (n)
        !           284:    ((lambda
        !           285:      (message break-level-count retval rettype ^w piport)
        !           286:      (cond ((>& n 0) 
        !           287:            (print 'error:)
        !           288:            (mapc '(lambda (a) (patom " ") (patom a) ) 
        !           289:                  (cdddr (arg 1)))
        !           290:            (terpr)
        !           291:            (cond ((caddr (arg 1)) (setq rettype 'contuab))
        !           292:                  ( t (setq rettype nil))))
        !           293:           ( t (setq rettype 'localcall)))
        !           294:      
        !           295:      (do nil (nil)
        !           296:         (cond ((dtpr 
        !           297:                 (setq retval
        !           298:                       (*catch
        !           299:                        'break-catch 
        !           300:                        (do ((form)) (nil)
        !           301:                            (patom "<")
        !           302:                            (patom break-level-count)
        !           303:                            (patom ">: ")
        !           304:                            (cond ((eq top-level-eof
        !           305:                                       (setq form (read nil top-level-eof)))
        !           306:                                   (cond ((null (status isatty))
        !           307:                                          (exit)))
        !           308:                                   (eval 1)     ; force interrupt check
        !           309:                                   (return (1- break-level-count)))
        !           310:                                  ((and (dtpr form)
        !           311:                                        (eq 'return (car form)))
        !           312:                                   (cond ((or (eq rettype 'contuab) 
        !           313:                                              (eq rettype 'localcall))
        !           314:                                          (return (ncons (eval (cadr form)))))
        !           315:                                         ( t (patom
        !           316:                                              "Can't continue from this error")
        !           317:                                             (terpr))))
        !           318:                                  ((and (dtpr form) (eq 'retbrk (car form)))
        !           319:                                   (cond ((numberp (setq form
        !           320:                                                         (eval (cadr form))))
        !           321:                                          (return form))
        !           322:                                         ( t (return (1- break-level-count)))))
        !           323:                                  ( t (pearlbreakprintfn (eval form))
        !           324:                                      (terpr)))))))
        !           325:                (return (cond ((eq rettype 'localcall) 
        !           326:                               (car retval))
        !           327:                              ( t retval))))
        !           328:               ((<& retval break-level-count)
        !           329:                (setq tpl-errlist errlist)
        !           330:                (*throw 'break-catch retval))
        !           331:               ( t (terpr)))))
        !           332:     nil
        !           333:     (1+ break-level-count)
        !           334:     nil
        !           335:     nil
        !           336:     nil
        !           337:     nil)))
        !           338: 
        !           339: (aliasdef 'break-err-handler 'pearl-break-err-handler)
        !           340: 
        !           341: ; vi: set lisp:

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.