From: Nikodemus Siivola Date: Sun, 6 Nov 2005 17:51:26 +0000 (+0000) Subject: 0.9.6.27: type inference from CHECK-TYPE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f92839873ac1714901906328e5c11b8a66544a21;p=sbcl.git 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 --- 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))))))) ;;;; DEFINE-SYMBOL-MACRO diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c58eb9e..8febbbf 100644 --- 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 --- 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"