tests/pprint.impure.lisp

   1 ;;;; test of the pretty-printer
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
  17 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
  18 ;;;; - didn't really work:
  19 ;;;;   "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
  20 ;;;;    (let ((*print-circle* t)) (describe (make-hash-table)))
  21 ;;;;  is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
  22 ;;;; ..."
  23 ;;;; So, this was mainly a pretty printing problem.
  24
  25 ;;; Create a circular list.
  26 (eval-when (:compile-toplevel :load-toplevel :execute)
  27   (defparameter *circ-list* '(1 1))
  28   (prog1 nil
  29     (setf (cdr *circ-list*) *circ-list*)))
  30
  31 ;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
  32 ;;; the #1= and mark *CIRC-LIST* as having been printed for the first
  33 ;;; time. After that any attempt to print *CIRC-LIST* must result in
  34 ;;; in a #1# being printed. Thus the right output is (for once)
  35 ;;; #1=#1#. -- JES, 2005-06-05
  36 #+nil
  37 ;;; circular lists are still being printed correctly?
  38 (assert (equal
  39          (with-output-to-string (*standard-output*)
  40            (let ((*print-circle* t))
  41              (pprint-logical-block (*standard-output* *circ-list*)
  42                                  (format *standard-output* "~S" *circ-list*))))
  43          "#1=(1 . #1#)"))
  44
  45 ;;; test from CLHS
  46 (assert (equal
  47          (with-output-to-string (*standard-output*)
  48           (let ((a (list 1 2 3)))
  49             (setf (cdddr a) a)
  50             (let ((*print-circle* t))
  51               (write a :stream *standard-output*))
  52             :done))
  53          "#1=(1 2 3 . #1#)"))
  54
  55 ;;; test case 1 for bug 99
  56 (assert (equal
  57          (with-output-to-string (*standard-output*)
  58            (let* ((*print-circle* t))
  59              (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
  60                      'eql 'eql)))
  61          "EQL is EQL. This was not seen!"))
  62
  63 ;;; test case 2 for bug 99
  64 (assert (equal
  65          (with-output-to-string (*standard-output*)
  66            (let* ((*print-circle* t))
  67              (format *standard-output*
  68                      "~@<~S ~_is ~S and ~S. This was not seen!~:>"
  69                      'eql 'eql 'eql)))
  70          "EQL is EQL and EQL. This was not seen!"))
  71
  72 ;;; the original test for BUG 99 (only interactive), no obvious
  73 ;;; way to make an automated test:
  74 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
  75
  76 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
  77 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
  78 (let ((list '(1 2 3))
  79       (prefix (make-array 2
  80                           :element-type 'character
  81                           :displaced-to ";x"
  82                           :fill-pointer 1))
  83       (suffix (make-array 2
  84                           :element-type 'character
  85                           :displaced-to ">xy"
  86                           :displaced-index-offset 1
  87                           :fill-pointer 1)))
  88   (assert (equal (with-output-to-string (s)
  89                    (pprint-logical-block (s list
  90                                             :per-line-prefix prefix
  91                                             :suffix suffix)
  92                      (format s "~{~W~^~:@_~}" list)))
  93                  (format nil ";1~%~
  94                               ;2~%~
  95                               ;3x"))))
  96
  97 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
  98 ;;; from , .FOO and , @FOO
  99 (assert (equal
 100          (with-output-to-string (s)
 101            (write '`(,  .foo) :stream s :pretty t :readably t))
 102          "`(, .FOO)"))
 103 (assert (equal
 104          (with-output-to-string (s)
 105            (write '`(,  @foo) :stream s :pretty t :readably t))
 106          "`(, @FOO)"))
 107 (assert (equal
 108          (with-output-to-string (s)
 109            (write '`(,  ?foo) :stream s :pretty t :readably t))
 110          "`(,?FOO)"))
 111
 112 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
 113 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
 114 (assert (equal
 115          (with-output-to-string (s)
 116            (write '`(foo ,x) :stream s :pretty t :readably t))
 117          "`(FOO ,X)"))
 118 (assert (equal
 119          (with-output-to-string (s)
 120            (write '`(foo ,@x) :stream s :pretty t :readably t))
 121          "`(FOO ,@X)"))
 122 #+nil ; '`(foo ,.x) => '`(foo ,@x) apparently.
 123 (assert (equal
 124          (with-output-to-string (s)
 125            (write '`(foo ,.x) :stream s :pretty t :readably t))
 126          "`(FOO ,.X)"))
 127 (assert (equal
 128          (with-output-to-string (s)
 129            (write '`(lambda ,x) :stream s :pretty t :readably t))
 130          "`(LAMBDA ,X)"))
 131 (assert (equal
 132          (with-output-to-string (s)
 133            (write '`(lambda ,@x) :stream s :pretty t :readably t))
 134          "`(LAMBDA ,@X)"))
 135 #+nil ; see above
 136 (assert (equal
 137          (with-output-to-string (s)
 138            (write '`(lambda ,.x) :stream s :pretty t :readably t))
 139          "`(LAMBDA ,.X)"))
 140 (assert (equal
 141          (with-output-to-string (s)
 142            (write '`(lambda (,x)) :stream s :pretty t :readably t))
 143          "`(LAMBDA (,X))"))
 144 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
 145 ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
 146 ;;; these assertions, like the ones above, are fragile.  Likewise, it
 147 ;;; is very possible that at some point READABLY printing backquote
 148 ;;; expressions will have to change to printing the low-level conses,
 149 ;;; since the magical symbols are accessible though (car '`(,foo)) and
 150 ;;; friends.  HATE HATE HATE.  -- CSR, 2004-06-10
 151 (assert (equal
 152          (with-output-to-string (s)
 153            (write '``(foo ,@',@bar) :stream s :pretty t))
 154          "``(FOO ,@',@BAR)"))
 155 (assert (equal
 156          (with-output-to-string (s)
 157            (write '``(,,foo ,',foo foo) :stream s :pretty t))
 158          "``(,,FOO ,',FOO FOO)"))
 159 (assert (equal
 160          (with-output-to-string (s)
 161            (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
 162          "``(((,,FOO) ,',FOO) FOO)"))
 163 \f
 164 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
 165 ;;; rush to coerce them to functions.
 166 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
 167 (defun ppd-function-name (s o)
 168   (print (length o) s))
 169 (let ((s (with-output-to-string (s)
 170            (pprint '(frob a b) s))))
 171   (assert (position #\3 s)))
 172 \f
 173 ;; Test that circularity detection works with pprint-logical-block
 174 ;; (including when called through pprint-dispatch).
 175 (let ((*print-pretty* t)
 176       (*print-circle* t)
 177       (*print-pprint-dispatch* (copy-pprint-dispatch)))
 178   (labels ((pprint-a (stream form &rest rest)
 179              (declare (ignore rest))
 180              (pprint-logical-block (stream form :prefix "<" :suffix ">")
 181                (pprint-exit-if-list-exhausted)
 182                (loop
 183                   (write (pprint-pop) :stream stream)
 184                   (pprint-exit-if-list-exhausted)
 185                   (write-char #\space stream)))))
 186     (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
 187     (assert (string= "<A 1 2 3>"
 188                      (with-output-to-string (s)
 189                        (write '(a 1 2 3) :stream s))))
 190     (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
 191                      (with-output-to-string (s)
 192                        (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
 193     (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
 194                      (with-output-to-string (s)
 195                        (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s))))))
 196
 197 ;; Test that a circular improper list inside a logical block works.
 198 (let ((*print-circle* t)
 199       (*print-pretty* t))
 200   (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
 201                    (with-output-to-string (s)
 202                      (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s)))))
 203
 204 ;;; Printing malformed defpackage forms without errors.
 205 (with-test (:name :pprint-defpackage)
 206   (with-open-stream (null (make-broadcast-stream))
 207     (pprint '(defpackage :foo nil))
 208     (pprint '(defpackage :foo 42))))
 209
 210 (with-test (:name :standard-pprint-dispatch-modified)
 211   (assert
 212    (eq :error
 213        (handler-case (with-standard-io-syntax
 214                        (set-pprint-dispatch 'symbol (constantly nil))
 215                        :no-error)
 216          (sb-int:standard-pprint-dispatch-table-modified-error ()
 217            :error)))))
 218 \f
 219 ;;; success