Return to toplevel.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib

Annotation of 43BSDReno/pgrm/lisp/lisplib/toplevel.l, revision 1.1

1.1     ! root        1: (setq rcs-toplevel-
        !             2:    "$Header: toplevel.l,v 1.6 83/11/18 08:47:24 jkf Exp $")
        !             3: 
        !             4: ;;
        !             5: ;; toplevel.l                          -[Sun Oct 30 08:14:49 1983 by jkf]-
        !             6: ;;
        !             7: ;;  toplevel read eval print loop
        !             8: ;;
        !             9: 
        !            10: 
        !            11: ; special atoms:
        !            12: (declare (special debug-level-count break-level-count
        !            13:                  errlist tpl-errlist user-top-level
        !            14:                  franz-not-virgin piport ER%tpl ER%all
        !            15:                  $ldprint evalhook funcallhook
        !            16:                  franz-minor-version-number
        !            17:                  top-level-init
        !            18:                  top-level-prompt top-level-read
        !            19:                  top-level-eval top-level-print
        !            20:                  top-level-eof * ** *** + ++ +++ ^w)
        !            21:          (localf autorunlisp cvtsearchpathtolist)
        !            22:         (macros t))
        !            23: 
        !            24: (setq top-level-eof (gensym 'Q)
        !            25:       tpl-errlist nil
        !            26:       errlist nil
        !            27:       user-top-level nil
        !            28:       top-level-init nil
        !            29:       top-level-prompt nil
        !            30:       top-level-read  nil
        !            31:       top-level-eval nil
        !            32:       top-level-print nil)
        !            33: 
        !            34: ;--- initialization, prompt, read, eval, and print functions are
        !            35: ; user-selectable by just assigning another value to top-level-init,
        !            36: ; top-level-prompt, top-level-read, top-level-eval, and top-level-print.
        !            37: ;
        !            38: (defmacro top-init nil
        !            39:    '(cond ((and top-level-init
        !            40:                (getd top-level-init))
        !            41:           (funcall top-level-init))
        !            42:          (t (cond ((not (autorunlisp))
        !            43:                    (patom (status version))
        !            44:                    ; franz-minor-version-number defined in version.l
        !            45:                    (cond ((boundp 'franz-minor-version-number)
        !            46:                           (patom franz-minor-version-number)))
        !            47:                    (terpr)
        !            48:                    (read-in-lisprc-file))))))
        !            49:      
        !            50: (defmacro top-prompt nil
        !            51:    `(cond ((and top-level-prompt
        !            52:                (getd top-level-prompt))
        !            53:           (funcall top-level-prompt))
        !            54:          (t (patom "-> "))))
        !            55: 
        !            56: (defmacro top-read (&rest args)
        !            57:    `(cond ((and top-level-read
        !            58:                (getd top-level-read))
        !            59:           (funcall top-level-read ,@args))
        !            60:          (t (read ,@args))))
        !            61: 
        !            62: (defmacro top-eval (&rest args)
        !            63:    `(cond ((and top-level-eval
        !            64:                (getd top-level-eval))
        !            65:           (funcall top-level-eval ,@args))
        !            66:          (t (eval ,@args))))
        !            67: 
        !            68: (defmacro top-print (&rest args)
        !            69:    `(cond ((and top-level-print
        !            70:                (getd top-level-print))
        !            71:           (funcall top-level-print ,@args))
        !            72:          (t (print ,@args))))
        !            73: 
        !            74: ;------------------------------------------------------
        !            75: ;  Top level function for franz                        jkf, march 1980
        !            76: ;
        !            77: ; The following function contains the top-level read, eval, print 
        !            78: ; loop.  With the help of the error handling functions, 
        !            79: ; break-err-handler and  debug-err-handler,  franz-top-level provides
        !            80: ; a reasonable enviroment for working with franz lisp.  
        !            81: ; 
        !            82: 
        !            83: (def franz-top-level
        !            84:   (lambda nil
        !            85:      (putd 'reset (getd 'franz-reset))
        !            86:      (username-to-dir-flush-cache)      ; clear tilde expansion knowledge
        !            87:       (cond ((or (not (boundp 'franz-not-virgin))
        !            88:                 (null franz-not-virgin))
        !            89:             (setq franz-not-virgin t
        !            90:                   + nil ++ nil +++ nil
        !            91:                   * nil ** nil *** nil)
        !            92:             (setq ER%tpl 'break-err-handler)
        !            93:             (top-init)))
        !            94:      
        !            95:      ; loop forever
        !            96:      (do ((+*) (-) (retval))
        !            97:         (nil)
        !            98:         (setq retval
        !            99:          (*catch 
        !           100:          '(top-level-catch break-catch)
        !           101:           ; begin or return to top level
        !           102:           (progn
        !           103:              (setq debug-level-count 0   break-level-count 0
        !           104:                   evalhook nil   funcallhook nil)
        !           105:              (cond (tpl-errlist (mapc 'eval tpl-errlist)))
        !           106:             (do ((^w nil nil))
        !           107:                 (nil)
        !           108:                 (cond (user-top-level (funcall user-top-level))
        !           109:                       (t (top-prompt)
        !           110:                          (cond ((eq top-level-eof
        !           111:                                     (setq - 
        !           112:                                           (car (errset (top-read nil 
        !           113:                                                              top-level-eof)))))
        !           114:                                 (cond ((not (status isatty))
        !           115:                                        (exit)))
        !           116:                                 (cond ((null (status ignoreeof))
        !           117:                                        (terpr)
        !           118:                                        (print 'Goodbye)
        !           119:                                        (terpr)
        !           120:                                        (exit))
        !           121:                                       (t (terpr)
        !           122:                                          (setq - ''EOF)))))
        !           123:                          (setq +* (top-eval -))
        !           124:                          ; update list of old forms
        !           125:                          (let ((val -))
        !           126:                               (let ((o+ +) (o++ ++))
        !           127:                                    (setq +   val
        !           128:                                          ++  o+
        !           129:                                          +++ o++)))
        !           130:                          ; update list of old values
        !           131:                          (let ((val +*))
        !           132:                               (let ((o* *) (o** **))
        !           133:                                    (setq *   val
        !           134:                                          **  o*
        !           135:                                          *** o**)))
        !           136:                          (top-print +*)
        !           137:                          (terpr)))))))
        !           138:         (terpr)
        !           139:         (patom "[Return to top level]")
        !           140:         (terpr)
        !           141:         (cond ((eq 'reset retval) (old-reset-function))))))
        !           142: 
        !           143: 
        !           144: 
        !           145: 
        !           146: 
        !           147: ; debug-err-handler is the clb of ER%all when we are doing debugging
        !           148: ; and we want to catch all errors.
        !           149: ; It is just a read eval print loop with errset.
        !           150: ; the only way to leave is: 
        !           151: ;   (reset) just back to top level
        !           152: ;   (return x) return the value to the error checker. 
        !           153: ;              if nil is returned then we will continue as if the error
        !           154: ;              didn't occur. Otherwise if the returned value is a list,
        !           155: ;              then if the error is continuable, the car of that list
        !           156: ;              will be returned to recontinue computation.
        !           157: ;   ^D continue as if this handler wasn't called.
        !           158: ; the form of errmsgs is:
        !           159: ;  (error_type unique_id continuable message_string other_args ...)
        !           160: ;
        !           161: (def debug-err-handler
        !           162:    (lexpr (n)
        !           163:          ((lambda (message debug-level-count retval ^w piport)
        !           164:              (cond ((greaterp n 0)
        !           165:                     (print 'Error:)
        !           166:                     (mapc '(lambda (a) (patom " ") (patom a) )
        !           167:                           (cdddr (arg 1)))
        !           168:                     (terpr)))
        !           169:              (setq ER%all 'debug-err-handler)
        !           170:              (do ((retval)) (nil)
        !           171:                  (cond ((dtpr
        !           172:                            (setq retval
        !           173:                                  (errset
        !           174:                                     (do ((form)) (nil)
        !           175:                                         (patom "D<")
        !           176:                                         (patom debug-level-count)
        !           177:                                         (patom ">: ")
        !           178:                                         (cond ((eq top-level-eof
        !           179:                                                    (setq form
        !           180:                                                          (top-read nil
        !           181:                                                                top-level-eof)))
        !           182:                                                (cond ((null (status isatty))
        !           183:                                                       (exit)))
        !           184:                                                (return nil))
        !           185:                                               ((and (dtpr form)
        !           186:                                                     (eq 'return
        !           187:                                                         (car form)))
        !           188:                                                (return (eval (cadr form))))
        !           189:                                               (t (setq form (top-eval form))
        !           190:                                                  (top-print form)
        !           191:                                                  (terpr)))))))
        !           192:                         (return (car retval))))))
        !           193:           nil
        !           194:           (add1 debug-level-count)
        !           195:           nil
        !           196:           nil
        !           197:           nil)))
        !           198: 
        !           199: ; this is the break handler, it should be tied to 
        !           200: ; ER%tpl always.
        !           201: ; it is entered if there is an error which no one wants to handle.
        !           202: ; We loop forever, printing out our error level until someone
        !           203: ; types a ^D which goes to the next break level above us (or the 
        !           204: ; top-level if there are no break levels above us.
        !           205: ; a (return n) will return that value to the error message
        !           206: ; which called us, if that is possible (that is if the error is
        !           207: ; continuable)
        !           208: ;
        !           209: (def break-err-handler
        !           210:    (lexpr (n)
        !           211:      ((lambda (message break-level-count retval rettype ^w piport)
        !           212:         (cond ((greaterp n 0)
        !           213:                (print 'Error:)
        !           214:                (mapc '(lambda (a) (patom " ") (patom a) )
        !           215:                      (cdddr (arg 1)))
        !           216:                (terpr)
        !           217:                (cond ((caddr (arg 1)) (setq rettype 'contuab))
        !           218:                      (t (setq rettype nil))))
        !           219:               (t (setq rettype 'localcall)))
        !           220: 
        !           221:         (do nil (nil)
        !           222:             (cond ((dtpr
        !           223:                       (setq retval
        !           224:                             (*catch 'break-catch
        !           225:                                 (do ((form)) (nil)
        !           226:                                     (patom "<")
        !           227:                                     (patom break-level-count)
        !           228:                                     (patom ">: ")
        !           229:                                     (cond ((eq top-level-eof
        !           230:                                                (setq form
        !           231:                                                      (top-read
        !           232:                                                         nil
        !           233:                                                         top-level-eof)))
        !           234:                                            (cond ((null (status isatty))
        !           235:                                                   (exit)))
        !           236:                                            (eval 1)    ; force interrupt check
        !           237:                                            (return (sub1 break-level-count)))
        !           238:                                           ((and (dtpr form)
        !           239:                                                 (eq 'return (car form)))
        !           240:                                            (cond ((or (eq rettype 'contuab)
        !           241:                                                       (eq rettype 'localcall))
        !           242:                                                   (return (ncons (top-eval (cadr form)))))
        !           243:                                                  (t (patom "Can't continue from this error")
        !           244:                                                     (terpr))))
        !           245:                                           ((and (dtpr form) (eq 'retbrk (car form)))
        !           246:                                            (cond ((numberp (setq form (top-eval (cadr form))))
        !           247:                                                   (return form))
        !           248:                                                  (t (return (sub1 break-level-count)))))
        !           249:                                           (t (setq form (top-eval form))
        !           250:                                              (top-print form)
        !           251:                                              (terpr)))))))
        !           252:                    (return (cond ((eq rettype 'localcall)
        !           253:                                   (car retval))
        !           254:                                  (t retval))))
        !           255:                   ((lessp retval break-level-count)
        !           256:                    (setq tpl-errlist errlist)
        !           257:                    (*throw 'break-catch retval))
        !           258:                   (t (terpr)))))
        !           259:       nil
        !           260:       (add1 break-level-count)
        !           261:       nil
        !           262:       nil
        !           263:       nil
        !           264:       nil)))
        !           265: 
        !           266: (defvar debug-error-handler 'debug-err-handler) ; name of function to get
        !           267:                                                ; control on ER%all error
        !           268: (def debugging 
        !           269:   (lambda (val)
        !           270:          (cond (val (setq ER%all debug-error-handler)
        !           271:                     (sstatus translink nil)
        !           272:                     (*rset t))
        !           273:                (t (setq ER%all nil)))))
        !           274: 
        !           275: 
        !           276: ; the problem with this definition for break is that we are
        !           277: ; forced to put an errset around the break-err-handler. This means
        !           278: ; that we will never get break errors, since all errors will be
        !           279: ; caught by our errset (better ours than one higher up though).
        !           280: ; perhaps the solution is to automatically turn debugmode on.
        !           281: ;
        !           282: (defmacro break (message &optional (pred t))
        !           283:   `(*break ,pred ',message))
        !           284: 
        !           285: (def *break
        !           286:   (lambda (pred message)
        !           287:      (let ((^w nil))
        !           288:          (cond ((not (boundp 'break-level-count)) (setq break-level-count 1)))
        !           289:          (cond (pred (terpr)
        !           290:                      (patom "Break ")
        !           291:                      (patom message)
        !           292:                      (terpr)
        !           293:                      (do ((form))
        !           294:                          (nil)
        !           295:                          (cond ((dtpr (setq form (errset (break-err-handler))))
        !           296:                                 (return (car form))))))))))
        !           297: 
        !           298: 
        !           299: ; this reset function is designed to work with the franz-top-level.
        !           300: ; When franz-top-level begins, it makes franz-reset be reset. 
        !           301: ; when a reset occurs now, we set the global variable tpl-errlist to 
        !           302: ; the current value of errlist and throw to top level.  At top level,
        !           303: ; then tpl-errlist will be evaluated.
        !           304: ;
        !           305: (def franz-reset
        !           306:   (lambda nil
        !           307:          (setq tpl-errlist errlist)
        !           308:          (errset (*throw 'top-level-catch 'reset)
        !           309:                  nil)
        !           310:          (old-reset-function)))
        !           311: 
        !           312: 
        !           313: (declare (special $ldprint))
        !           314: 
        !           315: ;--- read-in-lisprc-file
        !           316: ; search for a lisp init file.  Look first in . then in $HOME
        !           317: ; look first for .o , then .l and then "",
        !           318: ; look for file bodies .lisprc and then lisprc
        !           319: ; 
        !           320: (def read-in-lisprc-file
        !           321:    (lambda nil
        !           322:       (setq break-level-count 0        ; do this in case break
        !           323:            debug-level-count 0)   ; occurs during readin
        !           324:       (*catch '(break-catch top-level-catch)
        !           325:              (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
        !           326:                   ($ldprint nil $ldprint))     ; prevent messages
        !           327:                  ((null dirs))
        !           328:                  (cond ((do ((name '(".lisprc" "lisprc") (cdr name)))
        !           329:                             ((null name))
        !           330:                             (cond ((do ((ext '(".o" ".l" "") (cdr ext))
        !           331:                                         (file))
        !           332:                                        ((null ext))
        !           333:                                        (cond ((probef
        !           334:                                                  (setq file
        !           335:                                                        (concat (car dirs)
        !           336:                                                                "/"
        !           337:                                                                (car name)
        !           338:                                                                (car ext))))
        !           339:                                               (cond ((atom (errset (load file)))
        !           340:                                                      (patom
        !           341:                                                         "Error loading lisp init file ")
        !           342:                                                      (print file)
        !           343:                                                      (terpr)
        !           344:                                                      (return 'error)))
        !           345:                                               (return t))))
        !           346:                                    (return t))))
        !           347:                         (return t)))))))
        !           348: 
        !           349: (putd 'top-level (getd 'franz-top-level))
        !           350: 
        !           351: ; if this is the first time this file has been read in, then 
        !           352: ; make franz-reset be the reset function, but remember the original
        !           353: ; reset function as old-reset-function.  We need the old reset function
        !           354: ; if we are going to allow the user to change top-levels, for in 
        !           355: ; order to do that we really have to jump all the way up to the top.
        !           356: (cond ((null (getd 'old-reset-function))
        !           357:        (putd 'old-reset-function (getd 'reset))))
        !           358: 
        !           359: 
        !           360: ;---- autoloader functions
        !           361: 
        !           362: (def undef-func-handler
        !           363:   (lambda (args)
        !           364:     (prog (funcnam file)
        !           365:          (setq funcnam (caddddr args))
        !           366:          (cond ((symbolp funcnam) 
        !           367:                 (cond ((setq file (or (get funcnam 'autoload)
        !           368:                                       (get funcnam 'macro-autoload)))
        !           369:                        (cond ($ldprint
        !           370:                               (patom "[autoload ") (patom file)
        !           371:                               (patom "]")(terpr)))
        !           372:                        (load file))
        !           373:                       (t (return nil)))
        !           374:                 (cond ((getd funcnam) (return (ncons funcnam)))
        !           375:                       (t (patom "Autoload file " ) (print file)
        !           376:                          (patom " does not contain function ")
        !           377:                          (print funcnam)
        !           378:                          (terpr)
        !           379:                          (return nil))))))))
        !           380: 
        !           381: (setq ER%undef 'undef-func-handler)
        !           382: 
        !           383: (declare (special $ldprint))
        !           384: ;--- autorunlisp :: check if this lisp is supposed to run a program right
        !           385: ; away.
        !           386: ;
        !           387: (defun autorunlisp nil
        !           388:   (cond ((and (> (argv -1) 2) (equal (argv 1) '-f))
        !           389:         (let ((progname (argv 2))
        !           390:               ($ldprint nil)
        !           391:               (searchlist nil))        ; don't give fasl messages
        !           392:              (setq searchlist (cvtsearchpathtolist (getenv 'PATH)))
        !           393:              ; give two args to load to insure that a fasl is done.
        !           394:              (cond ((null 
        !           395:                      (errset (load-autorunobject progname searchlist)))
        !           396:                     (exit 0))
        !           397:                    (t t))))))
        !           398: 
        !           399: 
        !           400: (defun cvtsearchpathtolist (path)
        !           401:   (do ((x (explodec path) (cdr x))
        !           402:        (names nil)
        !           403:        (cur nil))
        !           404:       ((null x) 
        !           405:        (nreverse names))
        !           406:       (cond ((or (eq ': (car x)) 
        !           407:                 (and (null (cdr x)) (setq cur (cons (car x) cur))))
        !           408:             (cond (cur (setq names (cons (implode (nreverse cur))
        !           409:                                          names))
        !           410:                        (setq cur nil))
        !           411:                   (t (setq names (cons '|.| names)))))
        !           412:            (t (setq cur (cons (car x) cur))))))
        !           413: 
        !           414: (defun load-autorunobject (name search)
        !           415:   (cond ((memq (getchar name 1) '(/ |.|))
        !           416:         (cond ((probef name) (fasl name))
        !           417:               (t (error "From lisp autorun: can't find file to load"))))
        !           418:        (t (do ((xx search (cdr xx))
        !           419:                (fullname))
        !           420:               ((null xx) (error "Can't find file to execute "))
        !           421:               (cond ((probef (setq fullname (concat (car xx) "/" name)))
        !           422:                      (return (fasl-a-file fullname nil nil))))))))
        !           423: 
        !           424: ;--- command-line-args :: return a list of the command line arguments
        !           425: ; The list does not include the name of the program being executed (argv 0).
        !           426: ; It also doesn't include the autorun flag and arg.
        !           427: ;
        !           428: (defun command-line-args ()
        !           429:    (do ((res nil (cons (argv i) res))
        !           430:        (i (1- (argv -1)) (1- i)))
        !           431:        ((<& i 1)
        !           432:        (if (and (eq '-f (car res))
        !           433:                 (cdr res))
        !           434:           then (cddr res)
        !           435:           else res))))
        !           436: 
        !           437: (defun debug fexpr (args)
        !           438:   (load 'fix)  ; load in fix package
        !           439:   (eval (cons 'debug args)))   ; enter debug through eval
        !           440: 
        !           441: ;-- default autoloader properties
        !           442: 
        !           443: (putprop 'trace (concat lisp-library-directory "/trace") 'autoload)
        !           444: (putprop 'untrace (concat lisp-library-directory "/trace") 'autoload)
        !           445: 
        !           446: (putprop 'step (concat lisp-library-directory "/step") 'autoload)
        !           447: (putprop 'editf (concat lisp-library-directory "/cmuedit") 'autoload)
        !           448: (putprop 'editv (concat lisp-library-directory "/cmuedit") 'autoload)
        !           449: (putprop 'editp (concat lisp-library-directory "/cmuedit") 'autoload)
        !           450: (putprop 'edite (concat lisp-library-directory "/cmuedit") 'autoload)
        !           451: 
        !           452: (putprop 'defstruct (concat lisp-library-directory "/struct") 'macro-autoload)
        !           453: (putprop 'defstruct-expand-ref-macro
        !           454:         (concat lisp-library-directory "/struct") 'autoload)
        !           455: (putprop 'defstruct-expand-cons-macro
        !           456:         (concat lisp-library-directory "/struct") 'autoload)
        !           457: (putprop 'defstruct-expand-alter-macro
        !           458:          (concat lisp-library-directory "/struct") 'autoload)
        !           459: 
        !           460: (putprop 'loop      (concat lisp-library-directory "/loop")   'macro-autoload)
        !           461: (putprop 'defflavor
        !           462:         (concat lisp-library-directory "/flavors") 'macro-autoload)
        !           463: (putprop 'defflavor1
        !           464:         (concat lisp-library-directory "/flavors") 'autoload)
        !           465: 
        !           466: (putprop 'format (concat lisp-library-directory "/format") 'autoload)
        !           467: (putprop 'ferror (concat lisp-library-directory "/format") 'autoload)
        !           468: 
        !           469: (putprop 'make-hash-table
        !           470:         (concat lisp-library-directory "/hash") 'autoload)
        !           471: (putprop 'make-equal-hash-table
        !           472:         (concat lisp-library-directory "/hash") 'autoload)
        !           473: 
        !           474: (putprop 'describe (concat lisp-library-directory "/describe") 'autoload)
        !           475: 
        !           476: (putprop 'cgol (concat lisp-library-directory "/cgol/cgoll")   'autoload)
        !           477: (putprop 'cgolprint (concat lisp-library-directory "/cgol/cgp")   'autoload)
        !           478: 
        !           479: ; probably should be in franz so we don't have to autoload
        !           480: (putprop 'displace  (concat lisp-library-directory "/machacks")   'autoload)
        !           481: 
        !           482: (putprop 'defrecord (concat lisp-library-directory "/record") 'macro-autoload)
        !           483: (putprop 'record-pkg-construct
        !           484:    (concat lisp-library-directory "/record") 'autoload)
        !           485: (putprop 'record-pkg-access
        !           486:    (concat lisp-library-directory "/record") 'autoload)
        !           487: (putprop 'record-pkg-illegal-access
        !           488:    (concat lisp-library-directory "/record") 'autoload)

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