X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=73849728e70bdb13c4cef2832bc9e84e06f98732;hb=2c9e9cdf20257c422cd43bd30b89990499bca475;hp=7c84ba63ce8c6e6192ad1f9741ea1229a8769fa5;hpb=d51e3da4e408b17398f8219d490ec8c10812dfcf;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 7c84ba6..7384972 100644 --- 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.") ;;;; miscellaneous utilities for working with with TOPLEVEL @@ -75,16 +76,28 @@ command-line.") ;;; handled appropriately. (defmacro handling-end-of-the-world (&body body) (with-unique-names (caught) - `(let ((,caught (catch '%end-of-the-world - (/show0 "inside CATCH '%END-OF-THE-WORLD") - (unwind-protect - (progn ,@body) - (call-hooks "exit" *exit-hooks*))))) - (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output") - (flush-standard-output-streams) - (sb!thread::terminate-session) - (/show0 "calling UNIX-EXIT") - (sb!unix:unix-exit ,caught)))) + `(without-interrupts + (let ((,caught + (catch '%end-of-the-world + (unwind-protect + (with-local-interrupts ,@body (quit)) + (handler-case + (with-local-interrupts + (call-hooks "exit" *exit-hooks* :on-error :warn)) + (serious-condition () + 1)))))) + ;; If user called QUIT and exit hooks were OK, the status is what it + ;; is -- even eg. streams cannot be flushed anymore. Even if + ;; something goes wrong now, we still report what was asked. We still + ;; want to have %END-OF-THE-WORLD visible, though. + (catch '%end-of-the-world + (handler-case + (unwind-protect + (progn + (flush-standard-output-streams) + (sb!thread::terminate-session)) + (sb!unix:unix-exit ,caught)) + (serious-condition ()))))))) ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH* @@ -228,16 +241,41 @@ any non-negative real number." ;;; Flush anything waiting on one of the ANSI Common Lisp standard ;;; output streams before proceeding. (defun flush-standard-output-streams () - (dolist (name '(*debug-io* - *error-output* - *query-io* - *standard-output* - *trace-output* - *terminal-io*)) - ;; FINISH-OUTPUT may block more easily than FORCE-OUTPUT - (force-output (symbol-value name))) + (let ((null (make-broadcast-stream))) + (dolist (name '(*debug-io* + *error-output* + *query-io* + *standard-output* + *trace-output* + *terminal-io*)) + ;; 0. Pull out the underlying stream, so we know what it is. + ;; 1. Handle errors on it. We're doing this on entry to + ;; debugger, so we don't want recursive errors here. + ;; 2. Rebind the stream symbol in case some poor sod sees + ;; a broken stream here while running with *BREAK-ON-ERRORS*. + (let ((stream (stream-output-stream (symbol-value name)))) + (progv (list name) (list null) + (handler-bind ((stream-error + (lambda (c) + (when (eq stream (stream-error-stream c)) + (go :next))))) + (force-output stream)))) + :next)) (values)) +(defun stream-output-stream (stream) + (typecase stream + (fd-stream + stream) + (synonym-stream + (stream-output-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream + (stream-output-stream + (two-way-stream-output-stream stream))) + (t + stream))) + (defun process-init-file (specified-pathname kind) (multiple-value-bind (context default-function) (ecase kind @@ -275,22 +313,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)) - (quit))))) + (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 @@ -328,6 +383,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*))) @@ -354,7 +411,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) @@ -384,6 +441,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)) @@ -436,6 +503,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)