1.0.37.71: Minor test suite tweaks.

* Wrap WITH-TESTS around bare ASSERTS in pprint.impure.lisp. * Add #+sb-eval to test excercising the interpreter. (S.Boukarev)
akovalenko · Apr 27, 2010 · 70afa48 · 70afa48
1 parent 75974d2
commit 70afa48
Show file tree

Hide file tree

Showing 3 changed files with 134 additions and 123 deletions.
diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp
@@ -249,6 +249,7 @@
               (simple-type-error () 'error)))
       t)))
 
+#+sb-eval
 (with-test (:name :bug-524707)
   (let ((*evaluator-mode* :interpret)
         (lambda-form '(lambda (x) (declare (fixnum x)) (1+ x))))

diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp
@@ -43,163 +43,172 @@
          "#1=(1 . #1#)"))
 
 ;;; test from CLHS
-(assert (equal
-         (with-output-to-string (*standard-output*)
-          (let ((a (list 1 2 3)))
-            (setf (cdddr a) a)
-            (let ((*print-circle* t))
-              (write a :stream *standard-output*))
-            :done))
-         "#1=(1 2 3 . #1#)"))
-
-;;; test case 1 for bug 99
-(assert (equal
-         (with-output-to-string (*standard-output*)
-           (let* ((*print-circle* t))
-             (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
-                     'eql 'eql)))
-         "EQL is EQL. This was not seen!"))
-
-;;; test case 2 for bug 99
-(assert (equal
-         (with-output-to-string (*standard-output*)
-           (let* ((*print-circle* t))
-             (format *standard-output*
-                     "~@<~S ~_is ~S and ~S. This was not seen!~:>"
-                     'eql 'eql 'eql)))
-         "EQL is EQL and EQL. This was not seen!"))
+(with-test (:name :pprint-clhs-example)
+  (assert (equal
+           (with-output-to-string (*standard-output*)
+             (let ((a (list 1 2 3)))
+               (setf (cdddr a) a)
+               (let ((*print-circle* t))
+                 (write a :stream *standard-output*))
+               :done))
+           "#1=(1 2 3 . #1#)")))
+
+(with-test (:name :pprint :bug-99)
+  (assert (equal
+           (with-output-to-string (*standard-output*)
+             (let* ((*print-circle* t))
+               (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
+                       'eql 'eql)))
+           "EQL is EQL. This was not seen!"))
+
+  (assert (equal
+           (with-output-to-string (*standard-output*)
+             (let* ((*print-circle* t))
+               (format *standard-output*
+                       "~@<~S ~_is ~S and ~S. This was not seen!~:>"
+                       'eql 'eql 'eql)))
+           "EQL is EQL and EQL. This was not seen!")))
 
 ;;; the original test for BUG 99 (only interactive), no obvious
 ;;; way to make an automated test:
 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
 
 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
-(let ((list '(1 2 3))
-      (prefix (make-array 2
-                          :element-type 'character
-                          :displaced-to ";x"
-                          :fill-pointer 1))
-      (suffix (make-array 2
-                          :element-type 'character
-                          :displaced-to ">xy"
-                          :displaced-index-offset 1
-                          :fill-pointer 1)))
-  (assert (equal (with-output-to-string (s)
-                   (pprint-logical-block (s list
-                                            :per-line-prefix prefix
-                                            :suffix suffix)
-                     (format s "~{~W~^~:@_~}" list)))
-                 (format nil ";1~%~
+(with-test (:name :pprint-logical-block-arguments-complex-strings)
+  (let ((list '(1 2 3))
+        (prefix (make-array 2
+                            :element-type 'character
+                            :displaced-to ";x"
+                            :fill-pointer 1))
+        (suffix (make-array 2
+                            :element-type 'character
+                            :displaced-to ">xy"
+                            :displaced-index-offset 1
+                            :fill-pointer 1)))
+    (assert (equal (with-output-to-string (s)
+                     (pprint-logical-block (s list
+                                              :per-line-prefix prefix
+                                              :suffix suffix)
+                       (format s "~{~W~^~:@_~}" list)))
+                   (format nil ";1~%~
                               ;2~%~
-                              ;3x"))))
+                              ;3x")))))
 
 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
 ;;; from , .FOO and , @FOO
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(,  .foo) :stream s :pretty t :readably t))
-         "`(, .FOO)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(,  @foo) :stream s :pretty t :readably t))
-         "`(, @FOO)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(,  ?foo) :stream s :pretty t :readably t))
-         "`(,?FOO)"))
+(with-test (:name :pprint-backquote-magic)
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(,  .foo) :stream s :pretty t :readably t))
+           "`(, .FOO)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(,  @foo) :stream s :pretty t :readably t))
+           "`(, @FOO)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(,  ?foo) :stream s :pretty t :readably t))
+           "`(,?FOO)")))
 
 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(foo ,x) :stream s :pretty t :readably t))
-         "`(FOO ,X)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(foo ,@x) :stream s :pretty t :readably t))
-         "`(FOO ,@X)"))
-#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently.
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(foo ,.x) :stream s :pretty t :readably t))
-         "`(FOO ,.X)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(lambda ,x) :stream s :pretty t :readably t))
-         "`(LAMBDA ,X)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(lambda ,@x) :stream s :pretty t :readably t))
-         "`(LAMBDA ,@X)"))
-#+nil ; see above
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(lambda ,.x) :stream s :pretty t :readably t))
-         "`(LAMBDA ,.X)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '`(lambda (,x)) :stream s :pretty t :readably t))
-         "`(LAMBDA (,X))"))
+(with-test (:name :pprint :leaking-backq-comma)
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(foo ,x) :stream s :pretty t :readably t))
+           "`(FOO ,X)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(foo ,@x) :stream s :pretty t :readably t))
+           "`(FOO ,@X)"))
+  #+nil                       ; '`(foo ,.x) => '`(foo ,@x) apparently.
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(foo ,.x) :stream s :pretty t :readably t))
+           "`(FOO ,.X)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(lambda ,x) :stream s :pretty t :readably t))
+           "`(LAMBDA ,X)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(lambda ,@x) :stream s :pretty t :readably t))
+           "`(LAMBDA ,@X)"))
+  #+nil                                 ; see above
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(lambda ,.x) :stream s :pretty t :readably t))
+           "`(LAMBDA ,.X)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '`(lambda (,x)) :stream s :pretty t :readably t))
+           "`(LAMBDA (,X))")))
+
 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
 ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
 ;;; these assertions, like the ones above, are fragile.  Likewise, it
 ;;; is very possible that at some point READABLY printing backquote
 ;;; expressions will have to change to printing the low-level conses,
 ;;; since the magical symbols are accessible though (car '`(,foo)) and
 ;;; friends.  HATE HATE HATE.  -- CSR, 2004-06-10
-(assert (equal
-         (with-output-to-string (s)
-           (write '``(foo ,@',@bar) :stream s :pretty t))
-         "``(FOO ,@',@BAR)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '``(,,foo ,',foo foo) :stream s :pretty t))
-         "``(,,FOO ,',FOO FOO)"))
-(assert (equal
-         (with-output-to-string (s)
-           (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
-         "``(((,,FOO) ,',FOO) FOO)"))
+(with-test (:name :pprint-more-backquote-brokeness)
+  (assert (equal
+           (with-output-to-string (s)
+             (write '``(foo ,@',@bar) :stream s :pretty t))
+           "``(FOO ,@',@BAR)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '``(,,foo ,',foo foo) :stream s :pretty t))
+           "``(,,FOO ,',FOO FOO)"))
+  (assert (equal
+           (with-output-to-string (s)
+             (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
+           "``(((,,FOO) ,',FOO) FOO)")))
 
 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
 ;;; rush to coerce them to functions.
 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
 (defun ppd-function-name (s o)
   (print (length o) s))
+
+(with-test (:name :set-pprint-dispatch :no-function-coerce))
 (let ((s (with-output-to-string (s)
            (pprint '(frob a b) s))))
   (assert (position #\3 s)))
 
 ;; Test that circularity detection works with pprint-logical-block
 ;; (including when called through pprint-dispatch).
-(let ((*print-pretty* t)
-      (*print-circle* t)
-      (*print-pprint-dispatch* (copy-pprint-dispatch)))
-  (labels ((pprint-a (stream form &rest rest)
-             (declare (ignore rest))
-             (pprint-logical-block (stream form :prefix "<" :suffix ">")
-               (pprint-exit-if-list-exhausted)
-               (loop
-                  (write (pprint-pop) :stream stream)
-                  (pprint-exit-if-list-exhausted)
-                  (write-char #\space stream)))))
-    (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
-    (assert (string= "<A 1 2 3>"
-                     (with-output-to-string (s)
-                       (write '(a 1 2 3) :stream s))))
-    (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
-                     (with-output-to-string (s)
-                       (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
-    (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
-                     (with-output-to-string (s)
-                       (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s))))))
+(with-test (:name :pprint-circular-detection)
+  (let ((*print-pretty* t)
+        (*print-circle* t)
+        (*print-pprint-dispatch* (copy-pprint-dispatch)))
+    (labels ((pprint-a (stream form &rest rest)
+               (declare (ignore rest))
+               (pprint-logical-block (stream form :prefix "<" :suffix ">")
+                 (pprint-exit-if-list-exhausted)
+                 (loop
+                   (write (pprint-pop) :stream stream)
+                   (pprint-exit-if-list-exhausted)
+                   (write-char #\space stream)))))
+      (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
+      (assert (string= "<A 1 2 3>"
+                       (with-output-to-string (s)
+                         (write '(a 1 2 3) :stream s))))
+      (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
+                       (with-output-to-string (s)
+                         (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
+      (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
+                       (with-output-to-string (s)
+                         (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))))
 
 ;; Test that a circular improper list inside a logical block works.
-(let ((*print-circle* t)
-      (*print-pretty* t))
-  (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
-                   (with-output-to-string (s)
-                     (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s)))))
+(with-test (:name :pprint-circular-improper-lists-inside-logical-blocks)
+  (let ((*print-circle* t)
+        (*print-pretty* t))
+    (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
+                     (with-output-to-string (s)
+                       (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))))
 
 ;;; Printing malformed defpackage forms without errors.
 (with-test (:name :pprint-defpackage)
@@ -225,5 +234,6 @@
                    (to-string `(defmethod foo ((function cons)) function))))
     (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
                    (to-string `(defmethod foo :after (function cons) function))))))
+
 
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.37.70"
+"1.0.37.71"