make walker tests happier

  Our improved handling of specials in the walker broke a few tests,
  investigation of which revealed a few further bogosities -- patch
  over the worst of them, partially in the walker, partially by fixing
  tests which expected bogus results.

  LET* walking is still slightly broken when it comes to specials,
  since it isn't properly recursive the way it has to be. Mark the
  test as expected to fail for now -- fixing it ASAP properly.

  (I must have managed to run tests in the wrong tree once again,
  since I didn't catch this before the last push. Sorry!)

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index 15524a2..e8eb382 100644 (file)
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -158,9 +158,9 @@
              (copy-tree (mapcar (lambda (b)
                                   (let ((name (car b))
                                         (info (cadr b)))
-                                    (if (member info '(:lexical-var :special-var))
+                                    (if (eq info :lexical-var)
                                         (cons name
-                                              (if (eq :special-var info)
+                                              (if (var-special-p name env)
                                                   (sb!c::make-global-var
                                                    :kind :special
                                                    :%source-name name)
@@ -281,10 +281,7 @@
   (push declaration (caddr (env-lock env))))
 
 (defun note-var-binding (thing env)
-  (push (list thing (if (var-special-p thing env)
-                        :special-var
-                        :lexical-var))
-        (cadddr (env-lock env))))
+  (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 :test #'eq)))
@@ -301,10 +298,16 @@
 
 (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)))))
+    (if (eq 'special declaration)
+        (dolist (decl (env-declarations env))
+          (when (and (eq (car decl) declaration)
+                     (or (member var (cdr decl))
+                         (and id (member id (cdr decl)))))
+            (return decl)))
+        (dolist (decl (env-declarations env))
+          (when (and (eq (car decl) declaration)
+                     (eq (cadr decl) id))
+            (return decl))))))
 
 (defun var-declaration (declaration var env)
   (if (walked-var-declaration-p declaration)
@@ -731,20 +734,21 @@
     (let* ((let/let* (car form))
            (bindings (cadr form))
            (body (cddr form))
-           (walked-bindings nil)
+           walked-bindings
            (walked-body
-             (walk-declarations body
-                                (lambda (form env)
-                                  (setf walked-bindings
-                                        (walk-bindings-1 bindings
-                                                         old-env
-                                                         new-env
-                                                         context
-                                                         sequentialp))
-                                  (walk-repeat-eval form env))
-                                new-env)))
+             (walk-declarations
+              body
+              (lambda (real-body real-env)
+                (setf walked-bindings
+                      (walk-bindings-1 bindings
+                                       old-env
+                                       new-env
+                                       context
+                                       sequentialp))
+                (walk-repeat-eval real-body real-env))
+              new-env)))
       (relist*
-        form let/let* walked-bindings walked-body))))
+       form let/let* walked-bindings walked-body))))
 
 (defun walk-locally (form context old-env)
   (declare (ignore context))

diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp
index ce41e62..2fefd8f 100644 (file)
--- a/tests/walk.impure.lisp
+++ b/tests/walk.impure.lisp
@@ -36,8 +36,12 @@
                    (char= c #\newline)))
              s))
 (defun string=-modulo-tabspace (x y)
-  (string= (string-modulo-tabspace x)
-           (string-modulo-tabspace y)))
+  (if (string= (string-modulo-tabspace x)
+               (string-modulo-tabspace y))
+      t
+      (progn
+        (print (list :want y :got x))
+        nil)))
 \f
 ;;;; tests based on stuff at the end of the original CMU CL
 ;;;; pcl/walk.lisp file
@@ -344,7 +348,7 @@ Form: (TAGBODY)   Context: EVAL
         C)   Context: EVAL
 Form: (FOO A)   Context: EVAL
 Form: 'GLOBAL-FOO   Context: EVAL
-Form: B   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound; declared special
 Form: C   Context: EVAL; lexically bound
 (LET (A B C)
   (DECLARE (SPECIAL A B))
@@ -471,7 +475,7 @@ Form: B   Context: EVAL; lexically bound
 Form: (FOO A B)   Context: EVAL
 Form: 'GLOBAL-FOO   Context: EVAL
 Form: (LIST A B)   Context: EVAL
-Form: A   Context: EVAL; lexically bound
+Form: A   Context: EVAL; lexically bound; declared special
 Form: B   Context: EVAL; lexically bound
 (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))"))
 
@@ -580,30 +584,34 @@ Form: A   Context: EVAL
 Form: B   Context: EVAL
 Form: (LIST A B C)   Context: EVAL
 Form: A   Context: EVAL; lexically bound; declared special
-Form: B   Context: EVAL; lexically bound
+Form: B   Context: EVAL; lexically bound; declared special
 Form: C   Context: EVAL; lexically bound
 (LET ((A A) (B A) (C B))
   (DECLARE (SPECIAL A B))
   (LIST A B C))"))
 
-(assert (string=-modulo-tabspace
+;;;; Bug in LET* walking!
+(test-util:with-test (:name (:walk-let* :hairy-specials)
+                      :fails-on :sbcl)
+  (assert
+   (string=-modulo-tabspace
          (with-output-to-string (*standard-output*)
            (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
                                           (declare (special a b))
                                           (list a b c))))
          "Form: (LET* ((A A) (B A) (C B))
-        (DECLARE (SPECIAL A B))
-        (LIST A B C))   Context: EVAL
-Form: A   Context: EVAL
-Form: A   Context: EVAL; lexically bound
-Form: B   Context: EVAL; lexically bound
-Form: (LIST A B C)   Context: EVAL
-Form: A   Context: EVAL; lexically bound; declared special
-Form: B   Context: EVAL; lexically bound
-Form: C   Context: EVAL; lexically bound
-(LET* ((A A) (B A) (C B))
-  (DECLARE (SPECIAL A B))
-  (LIST A B C))"))
+                  (DECLARE (SPECIAL A B))
+                  (LIST A B C))   Context: EVAL
+          Form: A   Context: EVAL
+          Form: A   Context: EVAL; lexically bound; declared special
+          Form: B   Context: EVAL; lexically bound; declared special
+          Form: (LIST A B C)   Context: EVAL
+          Form: A   Context: EVAL; lexically bound; declared special
+          Form: B   Context: EVAL; lexically bound; declared special
+          Form: C   Context: EVAL; lexically bound
+          (LET* ((A A) (B A) (C B))
+            (DECLARE (SPECIAL A B))
+            (LIST A B C))")))
 
 (assert (string=-modulo-tabspace
          (with-output-to-string (*standard-output*)