BSD 4_2 development

[unix-history] / usr / lib / lisp / toplevel.l

diff --git a/usr/lib/lisp/toplevel.l b/usr/lib/lisp/toplevel.l
index 5e4fdd1..71aa2b9 100644 (file)
--- a/usr/lib/lisp/toplevel.l
+++ b/usr/lib/lisp/toplevel.l
@@ -1,18 +1,43 @@
-(setq SCCS-toplevel "@(#)toplevel.l    1.5     7/9/81")
-; vi: set lisp :
+(setq rcs-toplevel-
+   "$Header: /usr/lib/lisp/RCS/toplevel.l,v 1.2 83/03/27 18:10:28 jkf Exp $")
+
+;;
+;; toplevel.l                          -[Mon Mar 21 14:25:44 1983 by jkf]-
+;;
+;;  toplevel read eval print loop
+;;
+

 
 ; special atoms:
 (declare (special debug-level-count break-level-count
                  errlist tpl-errlist user-top-level
                  franz-not-virgin piport ER%tpl ER%all
                  $ldprint evalhook funcallhook
 
 ; special atoms:
 (declare (special debug-level-count break-level-count
                  errlist tpl-errlist user-top-level
                  franz-not-virgin piport ER%tpl ER%all
                  $ldprint evalhook funcallhook

+                 franz-minor-version-number
+                 top-level-print top-level-read

                  top-level-eof * ** *** + ++ +++ ^w)
                  top-level-eof * ** *** + ++ +++ ^w)

+         (localf autorunlisp cvtsearchpathtolist)

         (macros t))
 
 (setq top-level-eof (gensym 'Q)
       tpl-errlist nil
       errlist nil
         (macros t))
 
 (setq top-level-eof (gensym 'Q)
       tpl-errlist nil
       errlist nil

-      user-top-level nil )
+      user-top-level nil
+      top-level-print nil
+      top-level-read  nil)
+
+;--- read and print functions are user-selectable by just
+; assigning another value to top-level-print and top-level-read
+;
+(defmacro top-print (&rest args)
+   `(cond (top-level-print (funcall top-level-print ,@args))
+         (t (print ,@args))))
+
+(defmacro top-read (&rest args)
+   `(cond ((and top-level-read
+               (getd top-level-read))
+          (funcall top-level-read ,@args))
+         (t (read ,@args))))

 
 ;------------------------------------------------------
 ;  Top level function for franz                        jkf, march 1980
 
 ;------------------------------------------------------
 ;  Top level function for franz                        jkf, march 1980


@@ -25,15 +50,19 @@
 
 (def franz-top-level
   (lambda nil
 
 (def franz-top-level
   (lambda nil

+     (putd 'reset (getd 'franz-reset))
+     (username-to-dir-flush-cache)      ; clear tilde expansion knowledge

       (cond ((or (not (boundp 'franz-not-virgin))
                 (null franz-not-virgin))
             (setq franz-not-virgin t
                   + nil ++ nil +++ nil
                   * nil ** nil *** nil)
             (setq ER%tpl 'break-err-handler)
       (cond ((or (not (boundp 'franz-not-virgin))
                 (null franz-not-virgin))
             (setq franz-not-virgin t
                   + nil ++ nil +++ nil
                   * nil ** nil *** nil)
             (setq ER%tpl 'break-err-handler)

-            (putd 'reset (getd 'franz-reset))

             (cond ((not (autorunlisp))
                    (patom (status version))
             (cond ((not (autorunlisp))
                    (patom (status version))

+                   ; franz-minor-version-number defined in version.l
+                   (cond ((boundp 'franz-minor-version-number)
+                          (patom franz-minor-version-number)))

                    (terpr)
                    (read-in-lisprc-file)))))
      
                    (terpr)
                    (read-in-lisprc-file)))))
      


@@ -54,7 +83,7 @@
                       (t (patom "-> ")
                          (cond ((eq top-level-eof
                                     (setq - 
                       (t (patom "-> ")
                          (cond ((eq top-level-eof
                                     (setq - 

-                                          (car (errset (read nil 
+                                          (car (errset (top-read nil 

                                                              top-level-eof)))))
                                 (cond ((not (status isatty))
                                        (exit)))
                                                              top-level-eof)))))
                                 (cond ((not (status isatty))
                                        (exit)))


@@ -78,7 +107,7 @@
                                    (setq *   val
                                          **  o*
                                          *** o**)))
                                    (setq *   val
                                          **  o*
                                          *** o**)))

-                         (print +*)
+                         (top-print +*)

                          (terpr)))))))
         (terpr)
         (patom "[Return to top level]")
                          (terpr)))))))
         (terpr)
         (patom "[Return to top level]")


@@ -103,42 +132,42 @@
 ; the form of errmsgs is:
 ;  (error_type unique_id continuable message_string other_args ...)
 ;
 ; the form of errmsgs is:
 ;  (error_type unique_id continuable message_string other_args ...)
 ;

-(def debug-err-handler 
-  (lexpr (n)
-         ((lambda (message debug-level-count retval ^w piport 
-                           evalhook funcallhook)
-              (cond ((greaterp n 0)
-                     (print 'Error:)
-                     (mapc '(lambda (a) (patom " ") (patom a) ) 
-                           (cdddr (arg 1)))
-                     (terpr)))
-              (setq ER%all 'debug-err-handler)
-              (do (retval) (nil)
-                  (cond ((dtpr 
-                          (setq retval 
-                                (errset 
-                                 (do ((form)) (nil)
-                                     (patom "D<")
-                                     (patom debug-level-count)
-                                     (patom ">: ")
-                                     (cond ((eq top-level-eof
-                                               (setq form 
-                                                     (read nil top-level-eof)))
-                                            (cond ((null (status isatty))
-                                                   (exit)))
-                                            (return nil))
-                                           ((and (dtpr form)
-                                                 (eq 'return (car form)))
-                                            (return (eval (cadr form))))
-                                           (t (print (eval form))
-                                              (terpr)))))))
-                         (return (car retval))))))
+(def debug-err-handler
+   (lexpr (n)
+         ((lambda (message debug-level-count retval ^w piport)
+             (cond ((greaterp n 0)
+                    (print 'Error:)
+                    (mapc '(lambda (a) (patom " ") (patom a) )
+                          (cdddr (arg 1)))
+                    (terpr)))
+             (setq ER%all 'debug-err-handler)
+             (do ((retval)) (nil)
+                 (cond ((dtpr
+                           (setq retval
+                                 (errset
+                                    (do ((form)) (nil)
+                                        (patom "D<")
+                                        (patom debug-level-count)
+                                        (patom ">: ")
+                                        (cond ((eq top-level-eof
+                                                   (setq form
+                                                         (top-read nil
+                                                               top-level-eof)))
+                                               (cond ((null (status isatty))
+                                                      (exit)))
+                                               (return nil))
+                                              ((and (dtpr form)
+                                                    (eq 'return
+                                                        (car form)))
+                                               (return (eval (cadr form))))
+                                              (t (setq form (eval form))
+                                                 (top-print form)
+                                                 (terpr)))))))
+                        (return (car retval))))))

           nil
           (add1 debug-level-count)
           nil
           nil
           nil
           (add1 debug-level-count)
           nil
           nil

-          nil
-          nil

           nil)))
 \f
 ; this is the break handler, it should be tied to 
           nil)))
 \f
 ; this is the break handler, it should be tied to 


@@ -151,64 +180,69 @@
 ; which called us, if that is possible (that is if the error is
 ; continuable)
 ;
 ; which called us, if that is possible (that is if the error is
 ; continuable)
 ;

-(def break-err-handler 
-  (lexpr (n)
-         ((lambda (message break-level-count retval rettype ^w piport
-                           evalhook funcallhook)
-              (cond ((greaterp n 0) 
-                     (print 'Error:)
-                     (mapc '(lambda (a) (patom " ") (patom a) ) 
-                                   (cdddr (arg 1)))
-                     (terpr)
-                     (cond ((caddr (arg 1)) (setq rettype 'contuab))
-                           (t (setq rettype nil))))
-                    (t (setq rettype 'localcall)))
-
-              (do nil (nil)
-                  (cond ((dtpr 
-                          (setq retval
-                           (*catch 'break-catch 
-                            (do ((form)) (nil)
-                               (patom "<")
-                               (patom break-level-count)
-                               (patom ">: ")
-                               (cond ((eq top-level-eof
-                                          (setq form (read nil top-level-eof)))
-                                      (cond ((null (status isatty))
-                                             (exit)))
-                                      (eval 1)         ; force interrupt check
-                                      (return (sub1 break-level-count)))
-                                     ((and (dtpr form) (eq 'return (car form)))
-                                      (cond ((or (eq rettype 'contuab) 
-                                                 (eq rettype 'localcall))
-                                             (return (ncons (eval (cadr form)))))
-                                            (t (patom "Can't continue from this error")
-                                               (terpr))))
-                                     ((and (dtpr form) (eq 'retbrk (car form)))
-                                      (cond ((numberp (setq form (eval (cadr form))))
-                                             (return form))
-                                            (t (return (sub1 break-level-count)))))
-                                     (t (print (eval form))
-                                        (terpr)))))))
-                               (return (cond ((eq rettype 'localcall) 
-                                              (car retval))
-                                             (t retval))))
-                        ((lessp retval break-level-count)
-                         (setq tpl-errlist errlist)
-                         (*throw 'break-catch retval))
-                        (t (terpr)))))
-          nil
-          (add1 break-level-count)
-          nil
-          nil
-          nil
-          nil
-          nil
-          nil)))
+(def break-err-handler
+   (lexpr (n)
+     ((lambda (message break-level-count retval rettype ^w piport)
+        (cond ((greaterp n 0)
+               (print 'Error:)
+               (mapc '(lambda (a) (patom " ") (patom a) )
+                     (cdddr (arg 1)))
+               (terpr)
+               (cond ((caddr (arg 1)) (setq rettype 'contuab))
+                     (t (setq rettype nil))))
+              (t (setq rettype 'localcall)))
+
+        (do nil (nil)
+            (cond ((dtpr
+                      (setq retval
+                            (*catch 'break-catch
+                                (do ((form)) (nil)
+                                    (patom "<")
+                                    (patom break-level-count)
+                                    (patom ">: ")
+                                    (cond ((eq top-level-eof
+                                               (setq form
+                                                     (top-read
+                                                        nil
+                                                        top-level-eof)))
+                                           (cond ((null (status isatty))
+                                                  (exit)))
+                                           (eval 1)    ; force interrupt check
+                                           (return (sub1 break-level-count)))
+                                          ((and (dtpr form)
+                                                (eq 'return (car form)))
+                                           (cond ((or (eq rettype 'contuab)
+                                                      (eq rettype 'localcall))
+                                                  (return (ncons (eval (cadr form)))))
+                                                 (t (patom "Can't continue from this error")
+                                                    (terpr))))
+                                          ((and (dtpr form) (eq 'retbrk (car form)))
+                                           (cond ((numberp (setq form (eval (cadr form))))
+                                                  (return form))
+                                                 (t (return (sub1 break-level-count)))))
+                                          (t (setq form (eval form))
+                                             (top-print form)
+                                             (terpr)))))))
+                   (return (cond ((eq rettype 'localcall)
+                                  (car retval))
+                                 (t retval))))
+                  ((lessp retval break-level-count)
+                   (setq tpl-errlist errlist)
+                   (*throw 'break-catch retval))
+                  (t (terpr)))))
+      nil
+      (add1 break-level-count)
+      nil
+      nil
+      nil
+      nil)))

 \f
 \f

+(defvar debug-error-handler 'debug-err-handler) ; name of function to get
+                                               ; control on ER%all error

 (def debugging 
   (lambda (val)
 (def debugging 
   (lambda (val)

-         (cond (val (setq ER%all 'debug-err-handler)
+         (cond (val (setq ER%all debug-error-handler)
+                    (sstatus translink nil)

                     (*rset t))
                (t (setq ER%all nil)))))
 
                     (*rset t))
                (t (setq ER%all nil)))))
 


@@ -250,40 +284,41 @@
          (old-reset-function)))
 
 
          (old-reset-function)))
 
 

-; this definition will have to do until we have the ability to
-; cause and error on any channel in franz
-(def error
-  (lexpr (n)
-        (cond ((greaterp n 0)
-               (patom (arg 1))
-               
-               (cond  ((greaterp n 1)
-                       (patom " ")
-                       (patom (arg 2))))
-               (terpr)))
-        (err)))
-
+(declare (special $ldprint))

 
 

-; this file is read in just before dumplisping if you want .lisprc
-; from your home directory read in before the lisp begins.
+;--- read-in-lisprc-file
+; search for a lisp init file.  Look first in . then in $HOME
+; look first for .o , then .l and then "",
+; look for file bodies .lisprc and then lisprc
+; 

 (def read-in-lisprc-file
 (def read-in-lisprc-file

-  (lambda nil
-         ((lambda (hom prt)
-                  (setq break-level-count 0    ; do this in case break
-                        debug-level-count 0)   ; occurs during readin
-                  (*catch '(break-catch top-level-catch)
-                       (cond (hom
-                              (cond ((and 
-                                      (errset 
-                                       (progn
-                                        (setq prt (infile (concat hom '"/.lisprc")))
-                                        (close prt))
-                                       nil)
-                                      (null (errset
-                                             (load (concat hom '"/.lisprc")))))
-                                     (patom '"Error in .lisprc file detected")
-                                     (terpr)))))))
-          (getenv 'HOME) nil)))
+   (lambda nil
+      (setq break-level-count 0        ; do this in case break
+           debug-level-count 0)   ; occurs during readin
+      (*catch '(break-catch top-level-catch)
+             (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
+                  ($ldprint nil $ldprint))     ; prevent messages
+                 ((null dirs))
+                 (cond ((do ((name '(".lisprc" "lisprc") (cdr name)))
+                            ((null name))
+                            (cond ((do ((ext '(".o" ".l" "") (cdr ext))
+                                        (file))
+                                       ((null ext))
+                                       (cond ((probef
+                                                 (setq file
+                                                       (concat (car dirs)
+                                                               "/"
+                                                               (car name)
+                                                               (car ext))))
+                                              (cond ((atom (errset (load file)))
+                                                     (patom
+                                                        "Error loading lisp init file ")
+                                                     (print file)
+                                                     (terpr)
+                                                     (return 'error)))
+                                              (return t))))
+                                   (return t))))
+                        (return t)))))))

 
 (putd 'top-level (getd 'franz-top-level))
 
 
 (putd 'top-level (getd 'franz-top-level))
 


@@ -303,14 +338,18 @@
     (prog (funcnam file)
          (setq funcnam (caddddr args))
          (cond ((symbolp funcnam) 
     (prog (funcnam file)
          (setq funcnam (caddddr args))
          (cond ((symbolp funcnam) 

-                (cond ((setq file (get funcnam 'autoload))
+                (cond ((setq file (or (get funcnam 'autoload)
+                                      (get funcnam 'macro-autoload)))

                        (cond ($ldprint
                               (patom "[autoload ") (patom file)
                               (patom "]")(terpr)))
                        (load file))
                       (t (return nil)))
                 (cond ((getd funcnam) (return (ncons funcnam)))
                        (cond ($ldprint
                               (patom "[autoload ") (patom file)
                               (patom "]")(terpr)))
                        (load file))
                       (t (return nil)))
                 (cond ((getd funcnam) (return (ncons funcnam)))

-                      (t (patom "Autoload file does not contain func ")
+                      (t (patom "Autoload file " ) (print file)
+                         (patom " does not contain function ")
+                         (print funcnam)
+                         (terpr)

                          (return nil))))))))
 
 (setq ER%undef 'undef-func-handler)
                          (return nil))))))))
 
 (setq ER%undef 'undef-func-handler)


@@ -354,7 +393,20 @@
                (fullname))
               ((null xx) (error "Can't find file to execute "))
               (cond ((probef (setq fullname (concat (car xx) "/" name)))
                (fullname))
               ((null xx) (error "Can't find file to execute "))
               (cond ((probef (setq fullname (concat (car xx) "/" name)))

-                     (return (fasl fullname))))))))
+                     (return (fasl-a-file fullname nil nil))))))))
+
+;--- command-line-args :: return a list of the command line arguments
+; The list does not include the name of the program being executed (argv 0).
+; It also doesn't include the autorun flag and arg.
+;
+(defun command-line-args ()
+   (do ((res nil (cons (argv i) res))
+       (i (1- (argv -1)) (1- i)))
+       ((<& i 1)
+       (if (and (eq '-f (car res))
+                (cdr res))
+          then (cddr res)
+          else res))))

 
 (defun debug fexpr (args)
   (load 'fix)  ; load in fix package
 
 (defun debug fexpr (args)
   (load 'fix)  ; load in fix package


@@ -362,5 +414,36 @@
 
 ;-- default autoloader properties
 
 
 ;-- default autoloader properties
 

-(putprop 'trace '/usr/lib/lisp/trace 'autoload)
-(putprop 'step '/usr/lib/lisp/step 'autoload)
+(putprop 'trace (concat lisp-library-directory "/trace") 'autoload)
+(putprop 'step (concat lisp-library-directory "/step") 'autoload)
+(putprop 'editf (concat lisp-library-directory "/cmuedit") 'autoload)
+(putprop 'editv (concat lisp-library-directory "/cmuedit") 'autoload)
+(putprop 'editp (concat lisp-library-directory "/cmuedit") 'autoload)
+(putprop 'edite (concat lisp-library-directory "/cmuedit") 'autoload)
+
+(putprop 'defstruct (concat lisp-library-directory "/struct") 'macro-autoload)
+(putprop 'defstruct-expand-ref-macro
+        (concat lisp-library-directory "/struct") 'autoload)
+(putprop 'defstruct-expand-cons-macro
+        (concat lisp-library-directory "/struct") 'autoload)
+
+(putprop 'loop      (concat lisp-library-directory "/loop")   'macro-autoload)
+(putprop 'defflavor
+        (concat lisp-library-directory "/flavors") 'macro-autoload)
+(putprop 'defflavor1
+        (concat lisp-library-directory "/flavors") 'autoload)
+
+(putprop 'format (concat lisp-library-directory "/format") 'autoload)
+(putprop 'ferror (concat lisp-library-directory "/format") 'autoload)
+
+(putprop 'make-hash-table
+        (concat lisp-library-directory "/hash") 'autoload)
+(putprop 'make-equal-hash-table
+        (concat lisp-library-directory "/hash") 'autoload)
+
+(putprop 'describe (concat lisp-library-directory "/describe") 'autoload)
+
+(putprop 'cgol      (concat lisp-library-directory "/cgol")   'autoload)
+
+; probably should be in franz so we don't have to autoload
+(putprop 'displace  (concat lisp-library-directory "/machacks")   'autoload)