From 8a7fd84198f8a15e854f26b35cf13d2d280f5c78 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 3 Oct 2012 23:40:01 +0300 Subject: [PATCH] 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!) --- src/pcl/walk.lisp | 48 ++++++++++++++++++++++++++---------------------- tests/walk.impure.lisp | 44 ++++++++++++++++++++++++++------------------ 2 files changed, 52 insertions(+), 40 deletions(-) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 15524a2..e8eb382 100644 --- 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 --- 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))) ;;;; 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*) -- 1.7.10.4