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