X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=05445b9f36b481b74e46635dcbcc654c849648b4;hb=cc27e35fc73e6765679d6f426ee144abdfac7c27;hp=f5190028b4490a9d3fa4b4e56601f1460377dc1d;hpb=3969fabecc7837eff2c7a8f8f6dc1e0a127c80c8;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index f519002..05445b9 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* @@ -245,30 +258,19 @@ any non-negative real number." (values "sysinit" *sysinit-pathname-function*)) (:user (values "userinit" *userinit-pathname-function*))) - (flet ((process-stream (stream pathname) - (with-simple-restart (abort "Skip rest of ~A file ~S." - context (native-namestring pathname)) - (loop - (with-simple-restart - (continue "Ignore error and continue processing ~A file ~S." - context (native-namestring pathname)) - (let ((form (read stream nil stream))) - (if (eq stream form) - (return-from process-init-file nil) - (eval form)))))))) - (if specified-pathname - (with-open-file (stream (parse-native-namestring specified-pathname) - :if-does-not-exist nil) - (if stream - (process-stream stream (pathname stream)) - (cerror "Ignore missing init file" - "The specified ~A file ~A was not found." - context specified-pathname))) - (let ((default (funcall default-function))) - (when default - (with-open-file (stream (pathname default) :if-does-not-exist nil) - (when stream - (process-stream stream (pathname stream)))))))))) + (if specified-pathname + (with-open-file (stream (parse-native-namestring specified-pathname) + :if-does-not-exist nil) + (if stream + (load-as-source stream :context context) + (cerror "Ignore missing init file" + "The specified ~A file ~A was not found." + context specified-pathname))) + (let ((default (funcall default-function))) + (when default + (with-open-file (stream (pathname default) :if-does-not-exist nil) + (when stream + (load-as-source stream :context context)))))))) (defun process-eval/load-options (options) (/show0 "handling --eval and --load options") @@ -293,15 +295,30 @@ any non-negative real number." (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 @@ -365,7 +382,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)