From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Wed, 3 Nov 2004 02:11:43 +0000 (+0000)
Subject: 0.8.16.28:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ed2e811980a924df922505d6cc52fef8c76d85b5;p=sbcl.git

0.8.16.28:
	Fix CERROR when given a condition datum.
	... arguments are simply passed to the continue format control.
---

diff --git a/NEWS b/NEWS
index 974f9fa..9e1bcd6 100644
--- a/NEWS
+++ b/NEWS
@@ -44,6 +44,9 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
     ** constraint propagation and lambda variable substitution are
        more cautious in dealing with partially deleted code.
     ** compiler sometimes lost reoptimization passes.
+    ** CERROR, given a condition as condition designator, passes its
+       remaining arguments to the continue format control without
+       complaint.
 
 changes in sbcl-0.8.16 relative to sbcl-0.8.15:
   * enhancement: saving cores with foreign code loaded is now
diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index f532ab6..5dbdf5f 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -114,7 +114,7 @@
       (let ((condition (coerce-to-condition datum
 					    arguments
 					    'simple-error
-					    'error))
+					    'cerror))
 	    (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
 	(with-condition-restarts condition (list (find-restart 'continue))
 	  (let ((sb!debug:*stack-top-hint* nil))
diff --git a/src/code/error.lisp b/src/code/error.lisp
index b409a4f..86e41d1 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -27,14 +27,14 @@
 ;;; single argument that's directly usable by all the other routines.
 (defun coerce-to-condition (datum arguments default-type fun-name)
   (cond ((typep datum 'condition)
-	 (if arguments
-	     (cerror "Ignore the additional arguments."
-		     'simple-type-error
-		     :datum arguments
-		     :expected-type 'null
-		     :format-control "You may not supply additional arguments ~
-                                      when giving ~S to ~S."
-		     :format-arguments (list datum fun-name)))
+	 (when (and arguments (not (eq fun-name 'cerror)))
+           (cerror "Ignore the additional arguments."
+                   'simple-type-error
+                   :datum arguments
+                   :expected-type 'null
+                   :format-control "You may not supply additional arguments ~
+                                    when giving ~S to ~S."
+                   :format-arguments (list datum fun-name)))
 	 datum)
 	((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
 	 (apply #'make-condition datum arguments))
diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index 370ce4b..cddc4be 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -140,3 +140,14 @@
   (test t)
   (test 42)
   (test (make-instance 'standard-object)))
+
+;;; If CERROR is given a condition, any remaining arguments are only
+;;; used for the continue format control.
+(let ((x 0))
+  (handler-bind
+      ((simple-error (lambda (c) (incf x) (continue c))))
+    (cerror "Continue from ~A at ~A"
+            (make-condition 'simple-error :format-control "foo"
+                            :format-arguments nil)
+            'cerror (get-universal-time))
+    (assert (= x 1))))
diff --git a/version.lisp-expr b/version.lisp-expr
index bb81a17..80d267f 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".)
-"0.8.16.27"
+"0.8.16.28"