1.0.48.28: make TRULY-THE macroexpandable

[sbcl.git] / src / pcl / walk.lisp

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index 5f44953..4f93a74 100644 (file)
--- 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)))
 
@@ -267,29 +272,44 @@
   (push (list thing :lexical-var) (cadddr (env-lock env))))
 
 (defun var-lexical-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) :lexical-var)
       entry)))
 
 (defun variable-symbol-macro-p (var env)
-  (let ((entry (member var (env-lexical-variables env) :key #'car)))
+  (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
     (when (eq (cadar entry) 'sb!sys:macro)
       entry)))
 
-(defvar *var-declarations* '(special))
+(defun walked-var-declaration-p (declaration)
+  (member declaration '(sb!pcl::%class sb!pcl::%variable-rebinding special)))
+
+(defun %var-declaration (declaration var env)
+  (let ((id (or (var-lexical-p var env) var)))
+    (dolist (decl (env-declarations env))
+      (when (and (eq (car decl) declaration)
+                 (eq (cadr decl) id))
+        (return decl)))))
 
 (defun var-declaration (declaration var env)
-  (if (not (member declaration *var-declarations*))
-      (error "~S is not a recognized variable declaration." declaration)
-      (let ((id (or (var-lexical-p var env) var)))
-        (dolist (decl (env-declarations env))
-          (when (and (eq (car decl) declaration)
-                     (eq (cadr decl) id))
-            (return decl))))))
+  (if (walked-var-declaration-p declaration)
+      (%var-declaration declaration var env)
+      (error "Not a variable declaration the walker cares about: ~S" declaration)))
+
+#-sb-xc-host
+(define-compiler-macro var-declaration (&whole form declaration var env
+                                        &environment lexenv)
+  (if (sb!xc:constantp declaration lexenv)
+      (let ((decl (constant-form-value declaration lexenv)))
+        (if (walked-var-declaration-p decl)
+            `(%var-declaration ,declaration ,var ,env)
+            form))
+      form))
 
 (defun var-special-p (var env)
-  (or (not (null (var-declaration 'special var env)))
-      (var-globally-special-p var)))
+  (and (or (var-declaration 'special var env)
+           (var-globally-special-p var))
+       t))
 
 (defun var-globally-special-p (symbol)
   (eq (info :variable :kind symbol) :special))
@@ -450,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))
@@ -467,7 +492,7 @@
                 (multiple-value-bind (newnewform macrop)
                     (walker-environment-bind
                         (new-env env :walk-form newform)
-                      (sb-xc:macroexpand-1 newform new-env))
+                      (%macroexpand-1 newform new-env))
                   (cond
                    (macrop
                     (let ((newnewnewform (walk-form-internal newnewform
@@ -613,12 +638,12 @@
            (let ((type (car declaration))
                  (name (cadr declaration))
                  (args (cddr declaration)))
-             (if (member type *var-declarations*)
+             (if (walked-var-declaration-p type)
                  (note-declaration `(,type
                                      ,(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
@@ -629,7 +654,7 @@
               (null (get-walker-template (car form) form))
               (progn
                 (multiple-value-setq (new-form macrop)
-                                     (sb-xc:macroexpand-1 form env))
+                                     (%macroexpand-1 form env))
                 macrop))
          ;; This form was a call to a macro. Maybe it expanded
          ;; into a declare?  Recurse to find out.
@@ -653,7 +678,7 @@
                                          &aux arg)
   (cond ((null arglist) ())
         ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
+         (or (member arg sb!xc:lambda-list-keywords :test #'eq)
              (note-lexical-binding arg env))
          (recons arglist
                  arg
@@ -661,8 +686,7 @@
                                context
                                env
                                (and destructuringp
-                                    (not (member arg
-                                                 lambda-list-keywords))))))
+                                    (not (member arg sb!xc:lambda-list-keywords))))))
         ((consp arg)
          (prog1 (recons arglist
                         (if destructuringp
@@ -839,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