X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=73849728e70bdb13c4cef2832bc9e84e06f98732;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=e4cd7be6f50260f3dabb405154d81e79f7f92848;hpb=f486d6af546bace9f7442d37cb7ff245d144aa81;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index e4cd7be..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 @@ -240,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 @@ -287,21 +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)))))) + (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 +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*))) @@ -365,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) @@ -395,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)) @@ -447,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)