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 ;;;; Assert that entries inserted into a dispatch table with equal priority
  17 ;;;; are order-preserving - unless they are of the form (CONS (EQL x)).
  18 ;;;; This is not a requirement in general, but is quite reasonable.
  19 (with-test (:name :pprint-dispatch-order-preserving)
  20   (let ((tbl (sb-pretty::make-pprint-dispatch-table)))
  21     (handler-bind ((warning #'muffle-warning)) ; nonexistent types
  22       (set-pprint-dispatch 'foo1 #'pprint-fill 5 tbl)
  23       (set-pprint-dispatch 'fool #'pprint-fill 0 tbl)
  24       (set-pprint-dispatch 'foo2 #'pprint-fill 5 tbl))
  25     (let ((entries (sb-pretty::pprint-dispatch-table-entries tbl)))
  26       (assert (equal (mapcar #'sb-pretty::pprint-dispatch-entry-type entries)
  27                      '(foo1 foo2 fool))))))
  28
  29 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
  30 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
  31 ;;;; - didn't really work:
  32 ;;;;   "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
  33 ;;;;    (let ((*print-circle* t)) (describe (make-hash-table)))
  34 ;;;;  is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
  35 ;;;; ..."
  36 ;;;; So, this was mainly a pretty printing problem.
  37
  38 ;;; Create a circular list.
  39 (eval-when (:compile-toplevel :load-toplevel :execute)
  40   (defparameter *circ-list* '(1 1))
  41   (prog1 nil
  42     (setf (cdr *circ-list*) *circ-list*)))
  43
  44 ;;; I think this test is bogus. PPRINT-LOGICAL-BLOCK needs to print
  45 ;;; the #1= and mark *CIRC-LIST* as having been printed for the first
  46 ;;; time. After that any attempt to print *CIRC-LIST* must result in
  47 ;;; in a #1# being printed. Thus the right output is (for once)
  48 ;;; #1=#1#. -- JES, 2005-06-05
  49 #+nil
  50 ;;; circular lists are still being printed correctly?
  51 (assert (equal
  52          (with-output-to-string (*standard-output*)
  53            (let ((*print-circle* t))
  54              (pprint-logical-block (*standard-output* *circ-list*)
  55                                  (format *standard-output* "~S" *circ-list*))))
  56          "#1=(1 . #1#)"))
  57
  58 ;;; test from CLHS
  59 (with-test (:name :pprint-clhs-example)
  60   (assert (equal
  61            (with-output-to-string (*standard-output*)
  62              (let ((a (list 1 2 3)))
  63                (setf (cdddr a) a)
  64                (let ((*print-circle* t))
  65                  (write a :stream *standard-output*))
  66                :done))
  67            "#1=(1 2 3 . #1#)")))
  68
  69 (with-test (:name (:pprint :bug-99))
  70   (assert (equal
  71            (with-output-to-string (*standard-output*)
  72              (let* ((*print-circle* t))
  73                (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
  74                        'eql 'eql)))
  75            "EQL is EQL. This was not seen!"))
  76
  77   (assert (equal
  78            (with-output-to-string (*standard-output*)
  79              (let* ((*print-circle* t))
  80                (format *standard-output*
  81                        "~@<~S ~_is ~S and ~S. This was not seen!~:>"
  82                        'eql 'eql 'eql)))
  83            "EQL is EQL and EQL. This was not seen!")))
  84
  85 ;;; the original test for BUG 99 (only interactive), no obvious
  86 ;;; way to make an automated test:
  87 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
  88
  89 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
  90 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
  91 (with-test (:name :pprint-logical-block-arguments-complex-strings)
  92   (let ((list '(1 2 3))
  93         (prefix (make-array 2
  94                             :element-type 'character
  95                             :displaced-to ";x"
  96                             :fill-pointer 1))
  97         (suffix (make-array 2
  98                             :element-type 'character
  99                             :displaced-to ">xy"
 100                             :displaced-index-offset 1
 101                             :fill-pointer 1)))
 102     (assert (equal (with-output-to-string (s)
 103                      (pprint-logical-block (s list
 104                                               :per-line-prefix prefix
 105                                               :suffix suffix)
 106                        (format s "~{~W~^~:@_~}" list)))
 107                    (format nil ";1~%~
 108                               ;2~%~
 109                               ;3x")))))
 110
 111 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
 112 ;;; from , .FOO and , @FOO
 113 (with-test (:name :pprint-backquote-magic)
 114   (assert (equal
 115            (with-output-to-string (s)
 116              (write '`(,  .foo) :stream s :pretty t :readably t))
 117            "`(, .FOO)"))
 118   (assert (equal
 119            (with-output-to-string (s)
 120              (write '`(,  @foo) :stream s :pretty t :readably t))
 121            "`(, @FOO)"))
 122   (assert (equal
 123            (with-output-to-string (s)
 124              (write '`(,  ?foo) :stream s :pretty t :readably t))
 125            "`(,?FOO)")))
 126
 127 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
 128 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
 129 (with-test (:name :pprint-leaking-backq-comma)
 130   (assert (equal
 131            (with-output-to-string (s)
 132              (write '`(foo ,x) :stream s :pretty t :readably t))
 133            "`(FOO ,X)"))
 134   (assert (equal
 135            (with-output-to-string (s)
 136              (write '`(foo ,@x) :stream s :pretty t :readably t))
 137            "`(FOO ,@X)"))
 138   (assert (equal
 139            (with-output-to-string (s)
 140              (write '`(foo ,.x) :stream s :pretty t :readably t))
 141            "`(FOO ,.X)"))
 142   (assert (equal
 143            (with-output-to-string (s)
 144              (write '`(lambda ,x) :stream s :pretty t :readably t))
 145            "`(LAMBDA ,X)"))
 146   (assert (equal
 147            (with-output-to-string (s)
 148              (write '`(lambda ,@x) :stream s :pretty t :readably t))
 149            "`(LAMBDA ,@X)"))
 150   (assert (equal
 151            (with-output-to-string (s)
 152              (write '`(lambda ,.x) :stream s :pretty t :readably t))
 153            "`(LAMBDA ,.X)"))
 154   (assert (equal
 155            (with-output-to-string (s)
 156              (write '`(lambda (,x)) :stream s :pretty t :readably t))
 157            "`(LAMBDA (,X))")))
 158
 159 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
 160 ;;; and fixed a little more by DPK.
 161 (with-test (:name :pprint-more-backquote-brokeness)
 162   (flet ((try (input expect)
 163            (assert (equalp (read-from-string expect) input))
 164            (let ((actual (write-to-string input :pretty t)))
 165              (unless (equal actual expect)
 166              (error "Failed test for ~S. Got ~S~%"
 167                     expect actual)))))
 168     (try '``(foo ,@',@bar) "``(FOO ,@',@BAR)")
 169     (try '``(,,foo ,',foo foo) "``(,,FOO ,',FOO FOO)")
 170     (try '``(((,,foo) ,',foo) foo) "``(((,,FOO) ,',FOO) FOO)")
 171     (try '`#() "`#()")
 172     (try '`#(,bar) "`#(,BAR)")
 173     (try '`#(,(bar)) "`#(,(BAR))")
 174     (try '`#(,@bar) "`#(,@BAR)")
 175     (try '`#(,@(bar)) "`#(,@(BAR))")
 176     (try '`#(a ,b c) "`#(A ,B C)")
 177     (try '`#(,@A ,b c) "`#(,@A ,B C)")
 178     (try '`(,a . #(foo #() #(,bar) ,bar)) "`(,A . #(FOO #() #(,BAR) ,BAR))")
 179     (try '(let ((foo (x))) `(let (,foo) (setq ,foo (y)) (baz ,foo)))
 180            ;; PPRINT-LET emits a mandatory newline after the bindings,
 181            ;; otherwise this'd fit on one line given an adequate right margin.
 182            "(LET ((FOO (X)))
 183   `(LET (,FOO)
 184      (SETQ ,FOO (Y))
 185      (BAZ ,FOO)))")))
 186
 187 \f
 188 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
 189 ;;; rush to coerce them to functions.
 190 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
 191 (defun ppd-function-name (s o)
 192   (print (length o) s))
 193
 194 (with-test (:name (:set-pprint-dispatch :no-function-coerce)))
 195 (let ((s (with-output-to-string (s)
 196            (pprint '(frob a b) s))))
 197   (assert (position #\3 s)))
 198 \f
 199 ;; Test that circularity detection works with pprint-logical-block
 200 ;; (including when called through pprint-dispatch).
 201 (with-test (:name :pprint-circular-detection)
 202   (let ((*print-pretty* t)
 203         (*print-circle* t)
 204         (*print-pprint-dispatch* (copy-pprint-dispatch)))
 205     (labels ((pprint-a (stream form &rest rest)
 206                (declare (ignore rest))
 207                (pprint-logical-block (stream form :prefix "<" :suffix ">")
 208                  (pprint-exit-if-list-exhausted)
 209                  (loop
 210                    (write (pprint-pop) :stream stream)
 211                    (pprint-exit-if-list-exhausted)
 212                    (write-char #\space stream)))))
 213       (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
 214       (assert (string= "<A 1 2 3>"
 215                        (with-output-to-string (s)
 216                          (write '(a 1 2 3) :stream s))))
 217       (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
 218                        (with-output-to-string (s)
 219                          (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
 220       (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
 221                        (with-output-to-string (s)
 222                          (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))))
 223
 224 ;; Test that a circular improper list inside a logical block works.
 225 (with-test (:name :pprint-circular-improper-lists-inside-logical-blocks)
 226   (let ((*print-circle* t)
 227         (*print-pretty* t))
 228     (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
 229                      (with-output-to-string (s)
 230                        (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))))
 231
 232 ;;; Printing malformed defpackage forms without errors.
 233 (with-test (:name :pprint-defpackage)
 234   (let ((*standard-output* (make-broadcast-stream)))
 235     (pprint '(defpackage :foo nil))
 236     (pprint '(defpackage :foo 42))))
 237
 238 (with-test (:name :standard-pprint-dispatch-modified)
 239   (assert
 240    (eq :error
 241        (handler-case (with-standard-io-syntax
 242                        (set-pprint-dispatch 'symbol (constantly nil))
 243                        :no-error)
 244          (sb-int:standard-pprint-dispatch-table-modified-error ()
 245            :error)))))
 246
 247 (with-test (:name :pprint-defmethod-lambda-list-function)
 248   (flet ((to-string (form)
 249            (let ((string (with-output-to-string (s) (pprint form s))))
 250              (assert (eql #\newline (char string 0)))
 251              (subseq string 1))))
 252     (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
 253                    (to-string `(defmethod foo ((function cons)) function))))
 254     (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
 255                    (to-string `(defmethod foo :after (function cons) function))))))
 256
 257 (defclass frob () ())
 258
 259 (defmethod print-object ((obj frob) stream)
 260   (print-unreadable-object (obj stream :type nil :identity nil)
 261     (format stream "FRABOTZICATOR")))
 262
 263 ;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
 264 (with-test (:name (:pprint-unreadable-object :no-ugliness-when-type=nil))
 265   (assert (equal "#<FRABOTZICATOR>"
 266                  (let ((*print-right-margin* 5)
 267                        (*print-pretty* t))
 268                    (format nil "~@<~S~:>" (make-instance 'frob))))))
 269
 270 (with-test (:name :pprint-logical-block-code-deletion-node)
 271   (handler-case
 272       (compile nil
 273                `(lambda (words &key a b c)
 274                   (pprint-logical-block (nil words :per-line-prefix (or a b c))
 275                     (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))))
 276     ((or sb-ext:compiler-note warning) (c)
 277       (error c))))
 278
 279 (with-test (:name :pprint-logical-block-multiple-per-line-prefix-eval)
 280   (funcall (compile nil
 281                     `(lambda ()
 282                        (let ((n 0))
 283                          (with-output-to-string (s)
 284                            (pprint-logical-block (s nil :per-line-prefix (if (eql 1 (incf n))
 285                                                                              "; "
 286                                                                              (error "oops")))
 287                              (pprint-newline :mandatory s)
 288                              (pprint-newline :mandatory s)))
 289                          n)))))
 290
 291 (with-test (:name :can-restore-orig-pprint-dispatch-table)
 292   (let* ((orig (pprint-dispatch 'some-symbol))
 293          (alt (lambda (&rest args) (apply orig args))))
 294     (set-pprint-dispatch 'symbol alt)
 295     (assert (eq alt (pprint-dispatch 'some-symbol)))
 296     (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
 297     (assert (eq orig (pprint-dispatch 'some-symbol)))
 298     (assert (not (eq alt orig)))))
 299
 300 (with-test (:name :pprint-improper-list)
 301   (let* ((max-length 10)
 302          (stream (make-broadcast-stream))
 303          (errors
 304            (loop for symbol being the symbol in :cl
 305                  nconc
 306                  (loop for i from 1 below max-length
 307                        for list = (cons symbol 10) then (cons symbol list)
 308                        when (nth-value 1 (ignore-errors (pprint list stream)))
 309                        collect (format nil "(~{~a ~}~a . 10)" (butlast list) symbol)))))
 310     (when errors
 311       (error "Can't PPRINT improper lists: ~a" errors))))
 312
 313 (with-test (:name :pprint-circular-backq-comma)
 314   ;; LP 1161218 reported by James M. Lawrence
 315   (let ((string (write-to-string '(let ((#1=#:var '(99)))
 316                                    `(progn ,@(identity #1#)))
 317                                  :circle t :pretty t)))
 318     (assert (not (search "#2#" string)))))
 319
 320 (with-test (:name :pprint-dotted-setf)
 321   (let ((*print-pretty* t))
 322     (equal (format nil "~a" '(setf . a))
 323            "(SETF . A)")))
 324
 325 (with-test (:name :literal-fun-nested-lists)
 326   (assert (search "EQUALP" (format nil "~:w" `((((((,#'equalp)))))))
 327                   :test #'char-equal)))
 328
 329 (defvar *a* (make-array 3 :fill-pointer 0))
 330 (with-test (:name :pprint-logical-block-eval-order)
 331   (flet ((vp (x) (vector-push x *a*)))
 332     (pprint-logical-block (nil (progn (vp 1) '(foo))
 333                                :suffix (progn (vp 2) "}")
 334                                :prefix (progn (vp 3) "{"))
 335       (write (pprint-pop))))
 336   (assert (equalp *a* #(1 2 3))))
 337
 338 ;; these warn, but "work" in as much as they don't kill the machinery
 339 (with-test (:name (:pprint-dispatch :set-ppd-unknown-type))
 340   (handler-bind ((warning #'muffle-warning))
 341     (assert-signal
 342      (set-pprint-dispatch 'frood
 343                           (lambda (stream obj)
 344                             (let ((*print-pretty* nil))
 345                               (format stream "[frood: ~D]" obj))))
 346      warning)
 347     (assert-signal
 348      (set-pprint-dispatch '(or weasel (and woodle (satisfies thing)))
 349                           (lambda (stream obj)
 350                             (format stream "hi ~A!" (type-of obj))))
 351      warning)
 352     (write-to-string (macroexpand '(setf (values a b) (floor x y)))
 353                      :pretty t)
 354     ;; yay, we're not dead
 355     ))
 356
 357 (with-test (:name (:pprint-dispatch :unknown-type-1a))
 358   (assert (string= (write-to-string (list 1 2 3 1006) :pretty t)
 359                    "(1 2 3 1006)")))
 360 (deftype frood () '(integer 1005 1006))
 361 (with-test (:name (:pprint-dispatch :unknown-type-1b))
 362   (assert (string= (write-to-string (list 1 2 3 1006) :pretty t)
 363                    "(1 2 3 [frood: 1006])")))
 364 (defstruct weasel)
 365 (with-test (:name (:pprint-dispatch :unknown-type-2a))
 366   ;; still can't use the dispatch entry because of the OR
 367   ;; even though WEASEL "could have" eagerly returned T.
 368   (assert (string= (write-to-string (make-weasel) :pretty t)
 369                    "#S(WEASEL)")))
 370 (defstruct woodle)
 371 (with-test (:name (:pprint-dispatch :unknown-type-2b))
 372   ;; still no, because #'THING is not boundp
 373   (assert (string= (write-to-string (make-weasel) :pretty t)
 374                    "#S(WEASEL)"))
 375   (defun thing (x) x)
 376   (assert (string= (write-to-string (make-weasel) :pretty t)
 377                    "hi WEASEL!")))
 378 \f
 379 (deftype known-cons ()
 380   '(cons (member known-cons other-known-cons other-other)))
 381 (with-test (:name (:pprint-dispatch :known-cons-type))
 382   (flet ((pprint-known-cons (stream obj)
 383            (format stream "#<KNOWN-CONS ~S>" (cdr obj))))
 384     (set-pprint-dispatch 'known-cons #'pprint-known-cons))
 385   (let ((hashtable (sb-pretty::pprint-dispatch-table-cons-entries
 386                     *print-pprint-dispatch*)))
 387     ;; First ensure that the CONS table was used
 388     (assert (gethash 'known-cons hashtable))
 389     ;; Check that dispatch entries are shared. In practice it is not "useful"
 390     ;; but it is a consequence of the general approach of allowing any MEMBER
 391     ;; type versus disallowing MEMBER types of more than one element.
 392     (assert (eq (gethash 'known-cons hashtable)
 393                 (gethash 'other-known-cons hashtable)))
 394     (assert (eq (gethash 'known-cons hashtable)
 395                 (gethash 'other-other hashtable))))
 396   (assert (string= (write-to-string (cons 'known-cons t) :pretty t)
 397                    "#<KNOWN-CONS T>"))
 398   (assert (string= (write-to-string (cons 'known-cons (cons 'known-cons t)) :pretty t)
 399                    "#<KNOWN-CONS #<KNOWN-CONS T>>")))
 400
 401 ;;; success