Permalink
Browse files

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!)
  • Loading branch information...
nikodemus committed Oct 3, 2012
1 parent d90c8a7 commit 8a7fd84198f8a15e854f26b35cf13d2d280f5c78
Showing with 52 additions and 40 deletions.
  1. +26 −22 src/pcl/walk.lisp
  2. +26 −18 tests/walk.impure.lisp
View
@@ -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))
View
@@ -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)))
;;;; 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*)

0 comments on commit 8a7fd84

Please sign in to comment.