From 1877ee5664ef655c19b47deb22b5e18c36285f20 Mon Sep 17 00:00:00 2001
From: "Robert P. Goldman" <rpgoldman@sift.net>
Date: Sun, 31 Jul 2016 21:01:35 -0500
Subject: [PATCH] Alternative means of handling SERIOUS-CONDITION issues.

Previous method was over-complicated.  Now we simply appropriately
define the type UIOP:FATAL-CONDITION, and we can do without both
UIOP:*FATAL-CONDITIONS* and UIOP::*FATAL-CONDITION-EXCEPTIONS*.
---
 operate.lisp    |  2 +-
 uiop/image.lisp | 21 +++++++--------------
 2 files changed, 8 insertions(+), 15 deletions(-)

diff --git a/operate.lisp b/operate.lisp
index 28b621c80..755e997fc 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -220,7 +220,7 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms."))
           (handler-bind
               ((style-warning #'muffle-warning)
                (missing-component (constantly nil))
-               (serious-condition #'(lambda (e)
+               (uiop:fatal-condition #'(lambda (e)
                           (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                                   name e))))
             (let ((*verbose-out* (make-broadcast-stream)))
diff --git a/uiop/image.lisp b/uiop/image.lisp
index 3affc7140..fa1e9881c 100644
--- a/uiop/image.lisp
+++ b/uiop/image.lisp
@@ -7,7 +7,8 @@
    #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
    #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
    #:*lisp-interaction*
-   #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
+   #:fatal-condition #:fatal-condition-p
+   #:handle-fatal-condition
    #:call-with-fatal-condition-handler #:with-fatal-condition-handler
    #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
    #:*image-postlude* #:*image-dump-hook*
@@ -49,14 +50,8 @@ 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* '(SERIOUS-CONDITION)
-    "conditions that cause the Lisp image to enter the debugger if 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."))
-
+  (deftype fatal-condition ()
+    `(and serious-condition #+ccl (not ccl:process-reset))))
 
 ;;; Exiting properly or im-
 (with-upgradability ()
@@ -173,10 +168,8 @@ This is designed to abstract away the implementation specific quit forms."
                     condition)))
 
   (defun fatal-condition-p (condition)
-    "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
-    (and
-     (not (match-any-condition-p condition *fatal-condition-exceptions*))
-     (match-any-condition-p condition *fatal-conditions*)))
+    "Is the CONDITION fatal?"
+    (typep condition 'fatal-condition))
 
   (defun handle-fatal-condition (condition)
     "Handle a fatal CONDITION:
@@ -191,7 +184,7 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
 
   (defun call-with-fatal-condition-handler (thunk)
     "Call THUNK in a context where fatal conditions are appropriately handled"
-    (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
+    (handler-bind ((fatal-condition #'handle-fatal-condition))
       (funcall thunk)))
 
   (defmacro with-fatal-condition-handler ((&optional) &body body)
-- 
GitLab