From 9fd59ed8c1ea93b4795819790076afb096473d88 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Sun, 24 Jul 2016 18:25:47 -0500
Subject: [PATCH] Redefined *FATAL-CONDITIONS* per 1605650.

See https://bugs.launchpad.net/asdf/+bug/1605650

According to the spec, SERIOUS-CONDITIONs are "All conditions serious
enough to require interactive intervention if not handled should inherit
from the type serious-condition."  This is almost exactly the definition
of *FATAL-CONDITIONS*, so I substituted SERIOUS-CONDITION for ERROR
here.

Added exceptions to the set of *FATAL-CONDITIONS* in order to fix test
condition handling for CCL.  The exceptions permit us to have a class of
conditions (e.g., SERIOUS-CONDITION) that has a subclass that is not a
FATAL-CONDITION, but that does not have an obvious more specific
alternative.

The specific example that caused me to add this: On shutdown, CCL
signals CCL:PROCESS-RESET, a subclass of SERIOUS-CONDITION. So recent
test harness modifications to handle SERIOUS-CONDITIONs caused the test
scripts to mistakenly think there were failures because of calls to
EXIT-LISP.
---
 test/script-support.lisp |  8 +++++++-
 uiop/image.lisp          | 12 +++++++++---
 2 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/test/script-support.lisp b/test/script-support.lisp
index e4104481d..6b9f344a5 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -375,7 +375,13 @@ is bound, write a message and exit on an error.  If
   (let ((result
          (catch :asdf-test-done
            (handler-bind
-               ((serious-condition
+               (
+                #+ccl
+                (ccl:process-reset
+                 (lambda (c)
+                   (declare (ignore c))
+                   nil))
+                (serious-condition
                  (lambda (c)
                    (ignore-errors
                      (format *error-output* "~&TEST ABORTED: ~A~&" c))
diff --git a/uiop/image.lisp b/uiop/image.lisp
index 6b53acb04..3affc7140 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -49,9 +49,13 @@ before the image dump hooks are called and before the image is dumped.")
   (defvar *image-dump-hook* nil
     "Functions to call (in order) when before an image is dumped")
 
-  (defvar *fatal-conditions* '(error)
+  (defvar *fatal-conditions* '(SERIOUS-CONDITION)
     "conditions that cause the Lisp image to enter the debugger if interactive,
-or to die if not interactive"))
+or to die if not interactive")
+  (defvar *fatal-condition-exceptions*
+    (list #+ccl 'ccl:process-reset)
+    "Subclasses of condition that would match *FATAL-CONDITIONS* but that
+should not be treated as fatal."))
 
 
 ;;; Exiting properly or im-
@@ -170,7 +174,9 @@ This is designed to abstract away the implementation specific quit forms."
 
   (defun fatal-condition-p (condition)
     "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
-    (match-any-condition-p condition *fatal-conditions*))
+    (and
+     (not (match-any-condition-p condition *fatal-condition-exceptions*))
+     (match-any-condition-p condition *fatal-conditions*)))
 
   (defun handle-fatal-condition (condition)
     "Handle a fatal CONDITION:
-- 
GitLab