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