From: Juho Snellman <jsnell@iki.fi>
Date: Mon, 2 Oct 2006 06:38:35 +0000 (+0000)
Subject: 0.9.17.4:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e541b374b64104a47bb5e547778fbc81d5e0e0cb;p=sbcl.git

0.9.17.4:
	Fix the STORE-VALUE restart for CHECK-TYPE on non-variable places
        (DO considered harmful).
---

diff --git a/NEWS b/NEWS
index e3e283d..8bc1042 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.16:
   * bug fix: two potential GC deadlocks affecting threaded builds.
   * bug fix: (TYPEP #\A '(NOT (MEMBER #\" #\{ #\:))) now correctly
     returns T (reported by Anton Kazennikov)
+  * bug fix: the STORE-VALUE restart of CHECK-TYPE works correctly
+    with non-variable places
 
 changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16:
   * feature: weak hash tables, see MAKE-HASH-TABLE documentation
diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index e708663..efd3db0 100644
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -73,7 +73,7 @@ invoked. In that case it will store into PLACE and start over."
              ((typep ,place ',type))
           (setf ,place (check-type-error ',place ,place ',type ,type-string)))
         (let ((value (gensym)))
-          `(do ((,value ,place))
+          `(do ((,value ,place ,place))
                ((typep ,value ',type))
             (setf ,place
                   (check-type-error ',place ,value ',type ,type-string)))))))
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 31f8688..46a4bd6 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -364,3 +364,19 @@ ACTUAL ~D DERIVED ~D~%"
             (unless (member char chars)
               (assert (not (typep char type)))
               (assert (typep char not-type)))))))))
+
+(with-test (:name (:check-type :store-value :complex-place))
+  (let ((a (cons 0.0 2))
+        (handler-invoked nil))
+    (handler-bind ((error
+                    (lambda (c)
+                      (declare (ignore c))
+                      (assert (not handler-invoked))
+                      (setf handler-invoked t)
+                      (invoke-restart 'store-value 1))))
+      (check-type (car a) integer))
+    (assert (eql (car a) 1))))
+
+
+
+
diff --git a/version.lisp-expr b/version.lisp-expr
index ee3ea9c..3adfc5a 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.9.17.3"
+"0.9.17.4"