From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Sat, 26 Jun 2004 14:33:42 +0000 (+0000)
Subject: 0.8.12.2:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b72f483c96c09a775515af0104e3be831261ae36;p=sbcl.git

0.8.12.2:
	Fix for TYPE-ERROR-DATUM badness in CHECK-TYPE
	... and a test.
---

diff --git a/BUGS b/BUGS
index 61eb424..0963925 100644
--- a/BUGS
+++ b/BUGS
@@ -1389,12 +1389,6 @@ WORKAROUND:
     debugger invoked on a SB-INT:BUG in thread 27726:
       fasl stack not empty when it should be
 
-333: "CHECK-TYPE TYPE-ERROR-DATUM place"
-  (reported by Tony Martinez sbcl-devel 2004-05-23)
-  When CHECK-TYPE signals a TYPE-ERROR, the TYPE-ERROR-DATUM holds the
-  lisp symbolic place in question rather than the place's value.  This
-  seems wrong.
-
 334: "COMPUTE-SLOTS used to add slots to classes"
   (reported by Bruno Haible sbcl-devel 2004-06-01)
   a. Adding a local slot does not work:
diff --git a/NEWS b/NEWS
index f53a0d6..60ac550 100644
--- a/NEWS
+++ b/NEWS
@@ -2559,6 +2559,9 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12:
     The symbols are also exported from SB-PCL for backwards
     compatibility, but more so than before SB-PCL should be treated as
     an implementation-internal package.
+  * fixed bug #333: CHECK-TYPE now ensures that the type error
+    signalled, if any, has the right object to be accessed by
+    TYPE-ERROR-DATUM.  (reported by Tony Martinez)
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index a45cd62..5c64df2 100644
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -54,14 +54,6 @@
 ;;; and some things (e.g., READ-CHAR) can't afford this excessive
 ;;; consing, we bend backwards a little.
 ;;;
-;;; FIXME: In reality, this restart cruft is needed hardly anywhere in
-;;; the system. Write NEED and NEED-TYPE to replace ASSERT and
-;;; CHECK-TYPE inside the system. (CL:CHECK-TYPE must still be
-;;; defined, since it's specified by ANSI and it is sometimes nice for
-;;; whipping up little things. But as far as I can tell it's not
-;;; usually very helpful deep inside the guts of a complex system like
-;;; SBCL.)
-;;;
 ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
 ;;; the macro RESTART-CASE, which isn't defined until a later file.
 (defmacro-mundanely check-type (place type &optional type-string)
diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 7b89317..288f3e1 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -144,24 +144,15 @@
   (list (eval (read *query-io*))))
 
 (defun check-type-error (place place-value type type-string)
-  (let ((cond (if type-string
-		  (make-condition 'simple-type-error
-				  :datum place
-				  :expected-type type
-				  :format-control
-				  "The value of ~S is ~S, which is not ~A."
-				  :format-arguments (list place
-							  place-value
-							  type-string))
-		  (make-condition 'simple-type-error
-				  :datum place
-				  :expected-type type
-				  :format-control
-			  "The value of ~S is ~S, which is not of type ~S."
-				  :format-arguments (list place
-							  place-value
-							  type)))))
-    (restart-case (error cond)
+  (let ((condition
+	 (make-condition
+	  'simple-type-error
+	  :datum place-value
+	  :expected-type type
+	  :format-control
+	  "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
+	  :format-arguments (list place place-value type-string type))))
+    (restart-case (error condition)
       (store-value (value)
 	:report (lambda (stream)
 		  (format stream "Supply a new value for ~S." place))
diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index 0a4dd84..310562d 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -114,3 +114,11 @@
   (control-error (c) (format nil "~A" c))
   ;; there had better be an error
   (:no-error (&rest args) (error "No error: ~S" args)))
+
+(handler-case
+    (funcall (lambda (x) (check-type x fixnum) x) t)
+  (type-error (c)
+    (assert (and (subtypep (type-error-expected-type c) 'fixnum)
+		 (subtypep 'fixnum (type-error-expected-type c))))
+    (assert (eq (type-error-datum c) t)))
+  (:no-error (&rest rest) (error "no error: ~S" rest)))
diff --git a/version.lisp-expr b/version.lisp-expr
index db503a4..87145a1 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.12.1"
+"0.8.12.2"