0.9.6.27: type inference from CHECK-TYPE

 * Merge patch from Vincent Arkesteijn (sbcl-devel 2005-01-02)
   with a slight modification: use the new expansion only if place
   is a variable.

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 856edea..27535d6 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -56,17 +56,27 @@
 ;;;
 ;;; 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)
+(defmacro-mundanely check-type (place type &optional type-string
+                                &environment env)
   #!+sb-doc
-  "Signal a restartable error of type TYPE-ERROR if the value of PLACE is
-  not of the specified type. If an error is signalled and the restart is
-  used to return, this can only return if the STORE-VALUE restart is
-  invoked. In that case it will store into PLACE and start over."
-  (let ((place-value (gensym)))
-    `(do ((,place-value ,place ,place))
-         ((typep ,place-value ',type))
-       (setf ,place
-             (check-type-error ',place ,place-value ',type ,type-string)))))
+  "Signal a restartable error of type TYPE-ERROR if the value of PLACE
+is not of the specified type. If an error is signalled and the restart
+is used to return, this can only return if the STORE-VALUE restart is
+invoked. In that case it will store into PLACE and start over."
+  ;; KLUDGE: We use a simpler form of expansion if PLACE is just a
+  ;; variable to work around Python's blind spot in type derivation.
+  ;; For more complex places getting the type derived should not
+  ;; matter so much anyhow.
+  (let ((expanded (sb!xc:macroexpand place env)))
+    (if (symbolp expanded)
+        `(do ()
+             ((typep ,place ',type))
+          (setf ,place (check-type-error ',place ,place ',type ,type-string)))
+        (let ((value (gensym)))
+          `(do ((,value ,place))
+               ((typep ,value ',type))
+            (setf ,place
+                  (check-type-error ',place ,value ',type ,type-string)))))))
 \f
 ;;;; DEFINE-SYMBOL-MACRO
 

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index c58eb9e..8febbbf 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1888,3 +1888,20 @@
 ;;; sbcl-devel)
 (compile nil '(lambda (x y a b c)
                (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
+
+;;; Type inference from CHECK-TYPE
+(let ((count0 0) (count1 0))
+  (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
+    (compile nil '(lambda (x)
+                   (declare (optimize (speed 3)))
+                   (1+ x))))
+  ;; forced-to-do GENERIC-+, etc
+  (assert (= count0 4))
+  (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
+    (compile nil '(lambda (x)
+                   (declare (optimize (speed 3)))
+                   (check-type x fixnum)
+                   (1+ x))))
+  (assert (= count1 0)))
+
+

diff --git a/version.lisp-expr b/version.lisp-expr
index 5e8847e..9a43f72 100644 (file)
--- 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.6.26"
+"0.9.6.27"