1.0.48.29: better end-of-the-world handling

 * Implicit QUIT.

 * Make sure we have %END-OF-THE-WORLD visible while doing cleanups.

 * Handle errors from cleanups.

 * Disable interrupts in places where the environment might now be up to
   handling them yet/anymore.

 * If user calls QUIT, and exit hooks run without serious trouble, report the
   exit status requested even if there is trouble later flushing streams, etc.

 * Also make SAVE-LISP-AND-DIE signal an error if SAVE returns. (When there is
   eg. a file with the desired name but insufficient permissions.)

diff --git a/NEWS b/NEWS
index 319822c..4615575 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -36,6 +36,7 @@ changes relative to sbcl-1.0.48:
     1.0.43.57)
   * bug fix: TRULY-THE forms are now macroexpandable and setf-expandable.
     (lp#771673)
+  * bug fix: spurious errors during QUIT when standard streams were closed.
 
 changes in sbcl-1.0.48 relative to sbcl-1.0.47:
   * incompatible change: SB!KERNEL:INSTANCE-LAMBDA, deprecated for over five

diff --git a/src/code/save.lisp b/src/code/save.lisp
index 1ddf475..ed323a7 100644 (file)
--- a/src/code/save.lisp
+++ b/src/code/save.lisp
@@ -126,9 +126,7 @@ sufficiently motivated to do lengthy fixes."
              (handling-end-of-the-world
                (reinit)
                #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
-               (progn
-                 (funcall toplevel)
-                 (sb!ext:quit))))
+               (funcall toplevel)))
            (foreign-bool (value)
              (if value 1 0))
            (save-core (gc)
@@ -162,7 +160,11 @@ sufficiently motivated to do lengthy fixes."
            ;; Compact the environment even though we're skipping the
            ;; other purification stages.
            (sb!kernel::compact-environment-aux "Auxiliary" 200)
-           (save-core t)))))
+           (save-core t)))
+    ;; Something went very wrong -- reinitialize to have a prayer
+    ;; of being able to report the error.
+    (reinit)
+    (error "Could not save core.")))
 
 (defun deinit ()
   (call-hooks "save" *save-hooks*)

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 7c84ba6..e4cd7be 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -75,16 +75,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 ())))))))
 \f
 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
 
@@ -289,8 +301,7 @@ any non-negative real number."
         ;; 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)))))
+          (load f :verbose nil :print nil))))))
 
 ;; Errors while processing the command line cause the system to QUIT,
 ;; instead of trying to go into the Lisp debugger, because trying to

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 7323377..620d032 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -121,11 +121,10 @@
                         ;; any way.  (Depends on running in the main
                         ;; thread.) FIXME: On Windows we get two
                         ;; extra foreign frames below regular frames.
-                        (let ((end (last backtrace #-win32 2 #+win32 4)))
-                          (unless (equal (caar end)
-                                         'sb-impl::toplevel-init)
-                            (print (list :backtrace-stunted (caar end)))
-                            (setf result nil)))
+                        (unless (find '(sb-impl::toplevel-init) backtrace
+                                      :test #'equal)
+                          (print (list :backtrace-stunted backtrace))
+                          (setf result nil))
                         (return-from outer-handler)))))
           (funcall test-function)))
       result)))

diff --git a/tests/script.test.sh b/tests/script.test.sh
index a9ce19a..89693ff 100644 (file)
--- a/tests/script.test.sh
+++ b/tests/script.test.sh
@@ -24,13 +24,24 @@ run_sbcl --script $tmpscript
 check_status_maybe_lose "--script exit status from QUIT" $? 7 "(quit status good)"
 
 echo '(error "oops")' > $tmpscript
-run_sbcl --script $tmpscript
+run_sbcl --script $tmpscript 2> /dev/null
 check_status_maybe_lose "--script exit status from ERROR" $? 1 "(error implies 1)"
 
 echo 'nil'> $tmpscript
 run_sbcl --script $tmpscript
 check_status_maybe_lose "--script exit status from normal exit" $? 0 "(everything ok)"
 
+cat > $tmpscript <<EOF
+(setf *standard-output* (open "/dev/stdout"))
+(close *standard-output*)
+(sb-ext:quit :unix-status 3)
+EOF
+cat $tmpscript
+run_sbcl --script $tmpscript
+check_status_maybe_lose "--script exit status from QUIT when stdout closed" $? 3 "(as given)"
+run_sbcl --load $tmpscript
+check_status_maybe_lose "--load exit status from QUIT when stdout closed" $? 3 "(as given)"
+
 rm -f $tmpscript
 
 exit $EXIT_TEST_WIN

diff --git a/tests/smoke.impure.lisp b/tests/smoke.impure.lisp
index baeba31..f0069a7 100644 (file)
--- a/tests/smoke.impure.lisp
+++ b/tests/smoke.impure.lisp
@@ -72,4 +72,10 @@
   (assert (equal (funcall fn 1) '(1)))
   (assert (equal (funcall fn 1 2 3) '(1 2 3))))
 
+;;; Failure to save a core is an error
+(with-test (:name :save-lisp-and-die-error)
+  (assert (eq :oops
+              (handler-case (save-lisp-and-die "/")
+                (error () :oops)))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 76f3bbd..0799b72 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.48.28"
+"1.0.48.29"