(in-package :sb-walker)
\f
-;;;; stuff based on the tests at the end of the original CMU CL
+;;;; utilities to support tests
+
+;;; string equality modulo deletion of TABs and SPACEs (as a crude way
+;;; of washing away irrelevant differences in indentation)
+(defun string-modulo-tabspace (s)
+ (remove-if (lambda (c)
+ (or (char= c #\space)
+ (char= c #\tab)
+ (char= c #\newline)))
+ s))
+(defun string=-modulo-tabspace (x 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
(defmacro take-it-out-for-a-test-walk (form)
(defun take-it-out-for-a-test-walk-1 (form)
(let ((copy-of-form (copy-tree form))
- (result (walk-form form nil
- #'(lambda (x y env)
- (format t "~&Form: ~S ~3T Context: ~A" x y)
- (when (symbolp x)
- (let ((lexical (variable-lexical-p x env))
- (special (variable-special-p x env)))
- (when lexical
- (format t ";~3T")
- (format t "lexically bound"))
- (when special
- (format t ";~3T")
- (format t "declared special"))
- (when (boundp x)
- (format t ";~3T")
- (format t "bound: ~S " (eval x)))))
- x))))
+ (result (walk-form form nil
+ (lambda (x y env)
+ (format t "~&Form: ~S ~3T Context: ~A" x y)
+ (when (symbolp x)
+ (let ((lexical (var-lexical-p x env))
+ (special (var-special-p x env)))
+ (when lexical
+ (format t ";~3T")
+ (format t "lexically bound"))
+ (when special
+ (format t ";~3T")
+ (format t "declared special"))
+ (when (boundp x)
+ (format t ";~3T")
+ (format t "bound: ~S " (eval x)))))
+ x))))
(cond ((not (equal result copy-of-form))
- (format t "~%Warning: Result not EQUAL to copy of start."))
- ((not (eq result form))
- (format t "~%Warning: Result not EQ to copy of start.")))
+ (format t "~%Warning: Result not EQUAL to copy of start."))
+ ((not (eq result form))
+ (format t "~%Warning: Result not EQ to copy of start.")))
(pprint result)
nil))
(declare (ignore ignore))
''global-bar)
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (list arg1 arg2 arg3)))
"Form: (LIST ARG1 ARG2 ARG3) Context: EVAL
Form: ARG3 Context: EVAL
(LIST ARG1 ARG2 ARG3)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))))
"Form: (LIST (CONS 1 2) (LIST 3 4 5)) Context: EVAL
Form: 5 Context: EVAL
(LIST (CONS 1 2) (LIST 3 4 5))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn (foo) (bar 1))))
"Form: (PROGN (FOO) (BAR 1)) Context: EVAL
Form: 'GLOBAL-BAR Context: EVAL
(PROGN (FOO) (BAR 1))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (block block-name a b c)))
"Form: (BLOCK BLOCK-NAME A B C) Context: EVAL
Form: C Context: EVAL
(BLOCK BLOCK-NAME A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (block block-name (list a) b c)))
"Form: (BLOCK BLOCK-NAME (LIST A) B C) Context: EVAL
Form: C Context: EVAL
(BLOCK BLOCK-NAME (LIST A) B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)))
"Form: (CATCH CATCH-TAG (LIST A) B C) Context: EVAL
;;; This is a fairly simple MACROLET case. While walking the body of the
;;; macro, X should be lexically bound. In the body of the MACROLET form
;;; itself, X should not be bound.
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(macrolet ((foo (x) (list x) ''inner))
;;; the local macro definitions in a MACROLET, but the consequences
;;; are undefined if the local macro definitions reference any
;;; local variable or function bindings that are visible in that
-;;; lexical environment.
+;;; lexical environment.
;;; Since the behavior is undefined, anything we do conforms.:-|
;;; This is of course less than ideal; see bug 124.
#+nil
(foo)))))
(assert (and (null res) cond)))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(flet ((foo (x) (list x y))
(LIST X Y)))
(FOO 1))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(let ((y 2))
(LIST X Y)))
(FOO 1)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(labels ((foo (x) (bar x))
(FOO X)))
(FOO 1))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(flet ((foo (x) (foo x)))
(FOO X)))
(FOO 1))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(flet ((foo (x) (foo x)))
(FOO X)))
(BAR 1)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (prog () (declare (special a b)))))
"Form: (PROG () (DECLARE (SPECIAL A B))) Context: EVAL
Form: (TAGBODY) Context: EVAL
(PROG () (DECLARE (SPECIAL A B)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let (a b c)
(declare (special a b))
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))
B
C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let (a b c)
(declare (special a) (special b))
B
C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let (a b c)
(declare (special a))
B
C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let (a b c)
(declare (special a))
(FOO A)
B
C))"))
-
-(assert (equal
+
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (eval-when ()
a
Form: 'GLOBAL-FOO Context: EVAL
(EVAL-WHEN NIL A (FOO A))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(eval-when (:execute :compile-toplevel :load-toplevel)
Form: 'GLOBAL-FOO Context: EVAL
(EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (multiple-value-bind (a b)
(foo a b) (list a b))))
Form: B Context: EVAL; lexically bound
(MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (multiple-value-bind (a b)
(foo a b)
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))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn (function foo))))
"Form: (PROGN #'FOO) Context: EVAL
Form: #'FOO Context: EVAL
(PROGN #'FOO)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn a b (go a))))
"Form: (PROGN A B (GO A)) Context: EVAL
Form: (GO A) Context: EVAL
(PROGN A B (GO A))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (if a b c)))
"Form: (IF A B C) Context: EVAL
Form: C Context: EVAL
(IF A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (if a b)))
"Form: (IF A B) Context: EVAL
Form: A Context: EVAL
Form: B Context: EVAL
-Form: NIL Context: EVAL; bound: NIL
+Form: NIL Context: EVAL; bound: NIL
(IF A B)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)))
"Form: ((LAMBDA (A B) (LIST A B)) 1 2) Context: EVAL
Form: 2 Context: EVAL
((LAMBDA (A B) (LIST A B)) 1 2)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk ((lambda (a b)
(declare (special a))
Form: 2 Context: EVAL
((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
(list a b c))))
(LET ((A A) (B A) (C B))
(LIST A B C))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))))
"Form: (LET* ((A A) (B A) (C B))
(LET* ((A A) (B A) (C B))
(LIST A B C))"))
-(assert (equal
+(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))
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 (equal
+;;;; 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))"))
-
-(assert (equal
+ (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*)
(take-it-out-for-a-test-walk (let ((a 1) (b 2))
(foo bar)
(DECLARE (SPECIAL A))
(FOO A B)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)))
"Form: (MULTIPLE-VALUE-CALL #'FOO A B C) Context: EVAL
Form: C Context: EVAL
(MULTIPLE-VALUE-CALL #'FOO A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)))
"Form: (MULTIPLE-VALUE-PROG1 A B C) Context: EVAL
Form: C Context: EVAL
(MULTIPLE-VALUE-PROG1 A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn a b c)))
"Form: (PROGN A B C) Context: EVAL
Form: C Context: EVAL
(PROGN A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progv vars vals a b c)))
"Form: (PROGV VARS VALS A B C) Context: EVAL
Form: C Context: EVAL
(PROGV VARS VALS A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (quote a)))
"Form: 'A Context: EVAL
'A"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (return-from block-name a b c)))
"Form: (RETURN-FROM BLOCK-NAME A B C) Context: EVAL
Form: C Context: EVAL
(RETURN-FROM BLOCK-NAME A B C)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (setq a 1)))
"Form: (SETQ A 1) Context: EVAL
(SETQ A 1)"))
(makunbound 'a)
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)))
"Form: (SETQ A (FOO 1) B (BAR 2) C 3) Context: EVAL
(makunbound 'b)
(makunbound 'c)
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (tagbody a b c (go a))))
"Form: (TAGBODY A B C (GO A)) Context: EVAL
Form: (GO A) Context: EVAL
(TAGBODY A B C (GO A))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (the foo (foo-form a b c))))
"Form: (THE FOO (FOO-FORM A B C)) Context: EVAL
Form: C Context: EVAL
(THE FOO (FOO-FORM A B C))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (throw tag-form a)))
"Form: (THROW TAG-FORM A) Context: EVAL
Form: A Context: EVAL
(THROW TAG-FORM A)"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)))
"Form: (UNWIND-PROTECT (FOO A B) D E F) Context: EVAL
(declare (ignore a b))
''outer)
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
(LIST A B)))
(FLET-1 1 2)
(FOO 1 2)) Context: EVAL
-Form: NIL Context: EVAL; bound: NIL
+Form: NIL Context: EVAL; bound: NIL
Form: (FLET-1 A B) Context: EVAL
Form: 'OUTER Context: EVAL
Form: (LIST A B) Context: EVAL
(FLET-1 1 2)
(FOO 1 2))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk
(labels ((label-1 (a b) () (label-1 a b)(list a b)))
(LIST A B)))
(LABEL-1 1 2)
(FOO 1 2)) Context: EVAL
-Form: NIL Context: EVAL; bound: NIL
+Form: NIL Context: EVAL; bound: NIL
Form: (LABEL-1 A B) Context: EVAL
Form: A Context: EVAL; lexically bound
Form: B Context: EVAL; lexically bound
(LABEL-1 1 2)
(FOO 1 2))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
(macrolet-1 a b)
(MACROLET-1 A B)
(FOO 1 2))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
(foo 1))))
`(INNER-FOO-EXPANDED ,A)))
(FOO 1))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn (bar 1)
(macrolet ((bar (a)
`(INNER-BAR-EXPANDED ,A)))
(BAR 2)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (progn (bar 1)
(macrolet ((bar (s)
`(INNER-BAR-EXPANDED ,S)))
(BAR 2)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(take-it-out-for-a-test-walk (cond (a b)
((foo bar) a (foo a)))))
Form: (PROGN B) Context: EVAL
Form: B Context: EVAL
Form: (COND ((FOO BAR) A (FOO A))) Context: EVAL
-Form: (IF (FOO BAR) (PROGN A (FOO A)) (COND)) Context: EVAL
+Form: (IF (FOO BAR) (PROGN A (FOO A)) NIL) Context: EVAL
Form: (FOO BAR) Context: EVAL
Form: 'GLOBAL-FOO Context: EVAL
Form: (PROGN A (FOO A)) Context: EVAL
Form: A Context: EVAL
Form: (FOO A) Context: EVAL
Form: 'GLOBAL-FOO Context: EVAL
-Form: (COND) Context: EVAL
-Form: NIL Context: EVAL; bound: NIL
+Form: NIL Context: EVAL; bound: NIL
(COND (A B) ((FOO BAR) A (FOO A)))"))
-(assert (equal
+(assert (string=-modulo-tabspace
(with-output-to-string (*standard-output*)
(let ((the-lexical-variables ()))
(walk-form '(let ((a 1) (b 2))
- #'(lambda (x) (list a b x y)))
+ (lambda (x) (list a b x y)))
()
- #'(lambda (form context env)
- (declare (ignore context))
- (when (and (symbolp form)
- (variable-lexical-p form env))
- (push form the-lexical-variables))
- form))
+ (lambda (form context env)
+ (declare (ignore context))
+ (when (and (symbolp form)
+ (var-lexical-p form env))
+ (push form the-lexical-variables))
+ form))
(or (and (= (length the-lexical-variables) 3)
(member 'a the-lexical-variables)
(member 'b the-lexical-variables)
(error "Walker didn't do lexical variables of a closure properly."))))
""))
\f
-(quit :unix-status 104)
+;;;; more tests
+
+;;; Old PCL hung up on this.
+(defmethod #:foo ()
+ (defun #:bar ()))
+\f
\ No newline at end of file
projects / sbcl.git / blobdiff