refactor PRINT-NOT-READABLE condition signaling

[sbcl.git] / src / code / toplevel.lisp

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index e4cd7be..7f71449 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -56,16 +56,17 @@
 
 (defvar *sysinit-pathname-function* #'sysinit-pathname
   #!+sb-doc
-  "Designator for a function of zero arguments called to obtain a pathname
-designator for the default sysinit file, or NIL. If the function returns NIL,
-no sysinit file is used unless one has been specified on the command-line.")
+  "Designator for a function of zero arguments called to obtain a
+pathname designator for the default sysinit file, or NIL. If the
+function returns NIL, no sysinit file is used unless one has been
+specified on the command-line.")
 
 (defvar *userinit-pathname-function* #'userinit-pathname
   #!+sb-doc
-  "Designator for a function of zero arguments called to obtain a pathname
-designator or a stream for the default userinit file, or NIL. If the function
-returns NIL, no userinit file is used unless one has been specified on the
-command-line.")
+  "Designator for a function of zero arguments called to obtain a
+pathname designator or a stream for the default userinit file, or NIL.
+If the function returns NIL, no userinit file is used unless one has
+been specified on the command-line.")
 
 \f
 ;;;; miscellaneous utilities for working with with TOPLEVEL
@@ -287,21 +288,39 @@ any non-negative real number."
                (:load
                 (with-simple-restart (continue "Ignore runtime option --load ~S."
                                                value)
-                  (load (native-pathname value))))))
+                  (load (native-pathname value))))
+               (:quit
+                (quit))))
            (flush-standard-output-streams)))
     (with-simple-restart (abort "Skip rest of --eval and --load options.")
       (dolist (option options)
         (process-1 option)))))
 
 (defun process-script (script)
-  (let ((pathname (native-pathname script)))
+  (flet ((load-script (stream)
+           ;; Scripts don't need to be stylish or fast, but silence is usually a
+           ;; desirable quality...
+           (handler-bind (((or style-warning compiler-note) #'muffle-warning)
+                          (stream-error (lambda (e)
+                                          ;; Shell-style.
+                                          (when (member (stream-error-stream e)
+                                                        (list *stdout* *stdin* *stderr*))
+                                            (quit)))))
+             ;; Let's not use the *TTY* for scripts, ok? Also, normally we use
+             ;; synonym streams, but in order to have the broken pipe/eof error
+             ;; handling right we want to bind them for scripts.
+             (let ((*terminal-io* (make-two-way-stream *stdin* *stdout*))
+                   (*debug-io* (make-two-way-stream *stdin* *stderr*))
+                   (*standard-input* *stdin*)
+                   (*standard-output* *stdout*)
+                   (*error-output* *stderr*))
+               (load stream :verbose nil :print nil)))))
     (handling-end-of-the-world
-      (with-open-file (f pathname :element-type :default)
-        (sb!fasl::maybe-skip-shebang-line f)
-        ;; Scripts don't need to be stylish or fast, but silence is usually a
-        ;; desirable quality...
-        (handler-bind (((or style-warning compiler-note) #'muffle-warning))
-          (load f :verbose nil :print nil))))))
+      (if (eq t script)
+          (load-script *stdin*)
+          (with-open-file (f (native-pathname script) :element-type :default)
+            (sb!fasl::maybe-skip-shebang-line f)
+            (load-script f))))))
 
 ;; Errors while processing the command line cause the system to QUIT,
 ;; instead of trying to go into the Lisp debugger, because trying to
@@ -339,6 +358,8 @@ any non-negative real number."
         (noprint nil)
         ;; Has a --script option been seen?
         (script nil)
+        ;; Quit after processing other options?
+        (finally-quit nil)
         ;; everything in *POSIX-ARGV* except for argv[0]=programname
         (options (rest *posix-argv*)))
 
@@ -365,7 +386,7 @@ any non-negative real number."
                     (setf disable-debugger t
                           no-userinit t
                           no-sysinit t
-                          script (pop-option))
+                          script (if options (pop-option) t))
                     (return))
                    ((string= option "--sysinit")
                     (pop-option)
@@ -395,6 +416,16 @@ any non-negative real number."
                    ((string= option "--disable-debugger")
                     (pop-option)
                     (setf disable-debugger t))
+                   ((string= option "--quit")
+                    (pop-option)
+                    (setf finally-quit t))
+                   ((string= option "--non-interactive")
+                    ;; This option is short for --quit and --disable-debugger,
+                    ;; which are needed in combination for reliable non-
+                    ;; interactive startup.
+                    (pop-option)
+                    (setf finally-quit t)
+                    (setf disable-debugger t))
                    ((string= option "--end-toplevel-options")
                     (pop-option)
                     (return))
@@ -447,6 +478,8 @@ any non-negative real number."
               (process-init-file sysinit :system))
             (unless no-userinit
               (process-init-file userinit :user))
+            (when finally-quit
+              (push (list :quit) reversed-options))
             (process-eval/load-options (nreverse reversed-options))
             (when script
               (process-script script)