From: Nathan Froyd <froydnj@cs.rice.edu>
Date: Sat, 7 Apr 2007 01:13:23 +0000 (+0000)
Subject: 1.0.4.36: Commit Kevin Reid's "safer *break-on-signals*" patch.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=56205f12c189933cdd59b900925a171d5e311651;p=sbcl.git

1.0.4.36: Commit Kevin Reid's "safer *break-on-signals*" patch.
---

diff --git a/NEWS b/NEWS
index f25fa38..6abedd4 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,8 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4:
   * bug fix: some GC deadlocks caused by asynchronous interrupts have
     been fixed by inhibiting interrupts for when GC is disbled.
   * bug fix: GETHASH, PUTHASH, CLRHASH and REMHASH are now interrupt safe.
+  * bug fix: binding *BREAK-ON-SIGNALS* to a value that is not a type
+    specifier no longer causes infinite recursion.
   * improvement: the x86-64/darwin port now passes all tests and
     should be considered non-experimental.
 
diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index 4295160..96a5670 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -27,10 +27,16 @@
                                         'simple-condition
                                         'signal))
         (*handler-clusters* *handler-clusters*)
-        (old-bos *break-on-signals*))
+        (old-bos *break-on-signals*)
+        (bos-actually-breaking nil))
     (restart-case
-        (when (typep condition *break-on-signals*)
-          (let ((*break-on-signals* nil))
+        (let ((break-on-signals *break-on-signals*)
+              (*break-on-signals* nil))
+          ;; The rebinding encloses the TYPEP so that a bogus
+          ;; type specifier will not lead to infinite recursion when
+          ;; TYPEP fails.
+          (when (typep condition break-on-signals)
+            (setf bos-actually-breaking t)
             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
                     (now rebound to NIL)."
                    condition)))
@@ -45,7 +51,13 @@
       ;; unless we provide this restart.)
       (reassign (new-value)
         :report
-        "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*."
+        (lambda (stream)
+          (format stream
+                  (if bos-actually-breaking
+                    "Return from BREAK and assign a new value to ~
+                     *BREAK-ON-SIGNALS*."
+                    "Assign a new value to *BREAK-ON-SIGNALS* and ~
+                     continue with signal handling.")))
         :interactive
         (lambda ()
           (let (new-value)
diff --git a/tests/break-on-signals.impure.lisp b/tests/break-on-signals.impure.lisp
new file mode 100644
index 0000000..0c0b5c2
--- /dev/null
+++ b/tests/break-on-signals.impure.lisp
@@ -0,0 +1,25 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+
+;;; If *BREAK-ON-SIGNALS* has a bogus value, don't go off in an infinite
+;;; recursion.
+(assert
+  (catch 'ok
+    (handler-bind
+        ((error
+          (lambda (condition)
+            (when (search "NOT-A-TYPE-SPECIFIER" (princ-to-string condition))
+              (throw 'ok t)))))
+      (let ((*break-on-signals* '#:not-a-type-specifier))
+        (signal "foo"))
+    nil)))
diff --git a/version.lisp-expr b/version.lisp-expr
index 9120577..21f3d48 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,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.4.35"
+"1.0.4.36"