From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 31 Oct 2008 12:52:46 +0000 (+0000)
Subject: 1.0.22.4: symbol macros and type declarations in PCL
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cee152fc57eb64c73f6822a5b1ba8668f8aeb9b9;p=sbcl.git

1.0.22.4: symbol macros and type declarations in PCL

* When PCL walks the method body, doing permutation vector
   optimizations, take into account type declarations for symbol
   macros, to get the benefit of the declaration in

   (WITH-SLOTS (X) OBJECT ... (DECLARE (FIXNUM X)) ... (FOO X) ...)

   which currently happens only in DEFUN, where permuation vector
   optimizations do not occur.
---

diff --git a/NEWS b/NEWS
index d08cc36..d700a99 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-1.0.23 relative to 1.0.22:
   * optimization: printing with *PRINT-PRETTY* true is now more
     efficient as long as the object being printed doesn't require
     special handling by the pretty printer.
+  * bug fix: slot symbol-macros from WITH-SLOTS inside DEFMETHOD bodies
+    now interact correctly with type declarations.
 
 changes in sbcl-1.0.22 relative to 1.0.21:
   * minor incompatible change: LOAD-SHARED-OBJECT no longer by default looks
diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index ba16dfa..3f6d209 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -257,6 +257,11 @@
 (defun env-declarations (env)
   (caddr (env-lock env)))
 
+(defun env-var-type (var env)
+  (dolist (decl (env-declarations env) t)
+    (when (and (eq 'type (car decl)) (member var (cddr decl) :test 'eq))
+      (return (cadr decl)))))
+
 (defun env-lexical-variables (env)
   (cadddr (env-lock env)))
 
@@ -465,12 +470,17 @@
          ((not (consp newform))
           (let ((symmac (car (variable-symbol-macro-p newform env))))
             (if symmac
-                (let ((newnewform (walk-form-internal (cddr symmac)
-                                                      context
-                                                      env)))
-                  (if (eq newnewform (cddr symmac))
-                      (if *walk-form-expand-macros-p* newnewform newform)
-                      newnewform))
+                (let* ((newnewform (walk-form-internal (cddr symmac)
+                                                       context
+                                                       env))
+                       (resultform
+                        (if (eq newnewform (cddr symmac))
+                            (if *walk-form-expand-macros-p* newnewform newform)
+                            newnewform))
+                       (type (env-var-type newform env)))
+                  (if (eq t type)
+                      resultform
+                      `(the ,type ,resultform)))
                 newform)))
          (t
           (let* ((fn (car newform))
@@ -633,7 +643,7 @@
                                      ,(or (var-lexical-p name env) name)
                                      ,.args)
                                    env)
-                 (note-declaration declaration env))
+                 (note-declaration (sb!c::canonized-decl-spec declaration) env))
              (push declaration declarations)))
          (recons body
                  form
@@ -853,7 +863,10 @@
              (val (caddr form))
              (symmac (car (variable-symbol-macro-p var env))))
         (if symmac
-            (let* ((expanded `(setf ,(cddr symmac) ,val))
+            (let* ((type (env-var-type var env))
+                   (expanded (if (eq t type)
+                                 `(setf ,(cddr symmac) ,val)
+                                 `(setf ,(cddr symmac) `(the ,type ,val))))
                    (walked (walk-form-internal expanded context env)))
               (if (eq expanded walked)
                   form
diff --git a/version.lisp-expr b/version.lisp-expr
index df6e204..4bd98f4 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".)
-"1.0.22.3"
+"1.0.22.4"