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 (with-test (:name :pprint-clhs-example)
  47   (assert (equal
  48            (with-output-to-string (*standard-output*)
  49              (let ((a (list 1 2 3)))
  50                (setf (cdddr a) a)
  51                (let ((*print-circle* t))
  52                  (write a :stream *standard-output*))
  53                :done))
  54            "#1=(1 2 3 . #1#)")))
  55
  56 (with-test (:name (:pprint :bug-99))
  57   (assert (equal
  58            (with-output-to-string (*standard-output*)
  59              (let* ((*print-circle* t))
  60                (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
  61                        'eql 'eql)))
  62            "EQL is EQL. This was not seen!"))
  63
  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 (with-test (:name :pprint-logical-block-arguments-complex-strings)
  79   (let ((list '(1 2 3))
  80         (prefix (make-array 2
  81                             :element-type 'character
  82                             :displaced-to ";x"
  83                             :fill-pointer 1))
  84         (suffix (make-array 2
  85                             :element-type 'character
  86                             :displaced-to ">xy"
  87                             :displaced-index-offset 1
  88                             :fill-pointer 1)))
  89     (assert (equal (with-output-to-string (s)
  90                      (pprint-logical-block (s list
  91                                               :per-line-prefix prefix
  92                                               :suffix suffix)
  93                        (format s "~{~W~^~:@_~}" list)))
  94                    (format nil ";1~%~
  95                               ;2~%~
  96                               ;3x")))))
  97
  98 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
  99 ;;; from , .FOO and , @FOO
 100 (with-test (:name :pprint-backquote-magic)
 101   (assert (equal
 102            (with-output-to-string (s)
 103              (write '`(,  .foo) :stream s :pretty t :readably t))
 104            "`(, .FOO)"))
 105   (assert (equal
 106            (with-output-to-string (s)
 107              (write '`(,  @foo) :stream s :pretty t :readably t))
 108            "`(, @FOO)"))
 109   (assert (equal
 110            (with-output-to-string (s)
 111              (write '`(,  ?foo) :stream s :pretty t :readably t))
 112            "`(,?FOO)")))
 113
 114 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
 115 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
 116 (with-test (:name :pprint-leaking-backq-comma)
 117   (assert (equal
 118            (with-output-to-string (s)
 119              (write '`(foo ,x) :stream s :pretty t :readably t))
 120            "`(FOO ,X)"))
 121   (assert (equal
 122            (with-output-to-string (s)
 123              (write '`(foo ,@x) :stream s :pretty t :readably t))
 124            "`(FOO ,@X)"))
 125   #+nil                       ; '`(foo ,.x) => '`(foo ,@x) apparently.
 126   (assert (equal
 127            (with-output-to-string (s)
 128              (write '`(foo ,.x) :stream s :pretty t :readably t))
 129            "`(FOO ,.X)"))
 130   (assert (equal
 131            (with-output-to-string (s)
 132              (write '`(lambda ,x) :stream s :pretty t :readably t))
 133            "`(LAMBDA ,X)"))
 134   (assert (equal
 135            (with-output-to-string (s)
 136              (write '`(lambda ,@x) :stream s :pretty t :readably t))
 137            "`(LAMBDA ,@X)"))
 138   #+nil                                 ; see above
 139   (assert (equal
 140            (with-output-to-string (s)
 141              (write '`(lambda ,.x) :stream s :pretty t :readably t))
 142            "`(LAMBDA ,.X)"))
 143   (assert (equal
 144            (with-output-to-string (s)
 145              (write '`(lambda (,x)) :stream s :pretty t :readably t))
 146            "`(LAMBDA (,X))")))
 147
 148 ;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
 149 ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
 150 ;;; these assertions, like the ones above, are fragile.  Likewise, it
 151 ;;; is very possible that at some point READABLY printing backquote
 152 ;;; expressions will have to change to printing the low-level conses,
 153 ;;; since the magical symbols are accessible though (car '`(,foo)) and
 154 ;;; friends.  HATE HATE HATE.  -- CSR, 2004-06-10
 155 (with-test (:name :pprint-more-backquote-brokeness)
 156   (flet ((try (input expect)
 157            (assert (equalp (read-from-string expect) input))
 158            (let ((actual (write-to-string input :pretty t)))
 159              (unless (equal actual expect)
 160              (error "Failed test for ~S. Got ~S~%"
 161                     expect actual)))))
 162     (try '``(foo ,@',@bar) "``(FOO ,@',@BAR)")
 163     (try '``(,,foo ,',foo foo) "``(,,FOO ,',FOO FOO)")
 164     (try '``(((,,foo) ,',foo) foo) "``(((,,FOO) ,',FOO) FOO)")
 165     (try '`#() "`#()")
 166     (try '`#(,bar) "`#(,BAR)")
 167     (try '`#(,(bar)) "`#(,(BAR))")
 168     (try '`#(,@bar) "`#(,@BAR)")
 169     (try '`#(,@(bar)) "`#(,@(BAR))")
 170     (try '`#(a ,b c) "`#(A ,B C)")
 171     (try '`#(,@A ,b c) "`#(,@A ,B C)")
 172     (try '`(,a . #(foo #() #(,bar) ,bar)) "`(,A . #(FOO #() #(,BAR) ,BAR))")
 173     (try '(let ((foo (x))) `(let (,foo) (setq ,foo (y)) (baz ,foo)))
 174            ;; PPRINT-LET emits a mandatory newline after the bindings,
 175            ;; otherwise this'd fit on one line given an adequate right margin.
 176            "(LET ((FOO (X)))
 177   `(LET (,FOO)
 178      (SETQ ,FOO (Y))
 179      (BAZ ,FOO)))")))
 180
 181 \f
 182 ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
 183 ;;; rush to coerce them to functions.
 184 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
 185 (defun ppd-function-name (s o)
 186   (print (length o) s))
 187
 188 (with-test (:name (:set-pprint-dispatch :no-function-coerce)))
 189 (let ((s (with-output-to-string (s)
 190            (pprint '(frob a b) s))))
 191   (assert (position #\3 s)))
 192 \f
 193 ;; Test that circularity detection works with pprint-logical-block
 194 ;; (including when called through pprint-dispatch).
 195 (with-test (:name :pprint-circular-detection)
 196   (let ((*print-pretty* t)
 197         (*print-circle* t)
 198         (*print-pprint-dispatch* (copy-pprint-dispatch)))
 199     (labels ((pprint-a (stream form &rest rest)
 200                (declare (ignore rest))
 201                (pprint-logical-block (stream form :prefix "<" :suffix ">")
 202                  (pprint-exit-if-list-exhausted)
 203                  (loop
 204                    (write (pprint-pop) :stream stream)
 205                    (pprint-exit-if-list-exhausted)
 206                    (write-char #\space stream)))))
 207       (set-pprint-dispatch '(cons (eql a)) #'pprint-a)
 208       (assert (string= "<A 1 2 3>"
 209                        (with-output-to-string (s)
 210                          (write '(a 1 2 3) :stream s))))
 211       (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
 212                        (with-output-to-string (s)
 213                          (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
 214       (assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
 215                        (with-output-to-string (s)
 216                          (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))))
 217
 218 ;; Test that a circular improper list inside a logical block works.
 219 (with-test (:name :pprint-circular-improper-lists-inside-logical-blocks)
 220   (let ((*print-circle* t)
 221         (*print-pretty* t))
 222     (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
 223                      (with-output-to-string (s)
 224                        (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))))
 225
 226 ;;; Printing malformed defpackage forms without errors.
 227 (with-test (:name :pprint-defpackage)
 228   (let ((*standard-output* (make-broadcast-stream)))
 229     (pprint '(defpackage :foo nil))
 230     (pprint '(defpackage :foo 42))))
 231
 232 (with-test (:name :standard-pprint-dispatch-modified)
 233   (assert
 234    (eq :error
 235        (handler-case (with-standard-io-syntax
 236                        (set-pprint-dispatch 'symbol (constantly nil))
 237                        :no-error)
 238          (sb-int:standard-pprint-dispatch-table-modified-error ()
 239            :error)))))
 240
 241 (with-test (:name :pprint-defmethod-lambda-list-function)
 242   (flet ((to-string (form)
 243            (let ((string (with-output-to-string (s) (pprint form s))))
 244              (assert (eql #\newline (char string 0)))
 245              (subseq string 1))))
 246     (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
 247                    (to-string `(defmethod foo ((function cons)) function))))
 248     (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
 249                    (to-string `(defmethod foo :after (function cons) function))))))
 250
 251 (defclass frob () ())
 252
 253 (defmethod print-object ((obj frob) stream)
 254   (print-unreadable-object (obj stream :type nil :identity nil)
 255     (format stream "FRABOTZICATOR")))
 256
 257 ;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
 258 (with-test (:name (:pprint-unreadable-object :no-ugliness-when-type=nil))
 259   (assert (equal "#<FRABOTZICATOR>"
 260                  (let ((*print-right-margin* 5)
 261                        (*print-pretty* t))
 262                    (format nil "~@<~S~:>" (make-instance 'frob))))))
 263
 264 (with-test (:name :pprint-logical-block-code-deletion-node)
 265   (handler-case
 266       (compile nil
 267                `(lambda (words &key a b c)
 268                   (pprint-logical-block (nil words :per-line-prefix (or a b c))
 269                     (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))))
 270     ((or sb-ext:compiler-note warning) (c)
 271       (error e))))
 272
 273 (with-test (:name :pprint-logical-block-multiple-per-line-prefix-eval)
 274   (funcall (compile nil
 275                     `(lambda ()
 276                        (let ((n 0))
 277                          (with-output-to-string (s)
 278                            (pprint-logical-block (s nil :per-line-prefix (if (eql 1 (incf n))
 279                                                                              "; "
 280                                                                              (error "oops")))
 281                              (pprint-newline :mandatory s)
 282                              (pprint-newline :mandatory s)))
 283                          n)))))
 284
 285 (with-test (:name :can-restore-orig-pprint-dispatch-table)
 286   (let* ((orig (pprint-dispatch 'some-symbol))
 287          (alt (lambda (&rest args) (apply orig args))))
 288     (set-pprint-dispatch 'symbol alt)
 289     (assert (eq alt (pprint-dispatch 'some-symbol)))
 290     (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
 291     (assert (eq orig (pprint-dispatch 'some-symbol)))
 292     (assert (not (eq alt orig)))))
 293
 294 (with-test (:name :pprint-improper-list)
 295   (let* ((max-length 10)
 296          (stream (make-broadcast-stream))
 297          (errors
 298            (loop for symbol being the symbol in :cl
 299                  nconc
 300                  (loop for i from 1 below max-length
 301                        for list = (cons symbol 10) then (cons symbol list)
 302                        when (nth-value 1 (ignore-errors (pprint list stream)))
 303                        collect (format nil "(~{~a ~}~a . 10)" (butlast list) symbol)))))
 304     (when errors
 305       (error "Can't PPRINT improper lists: ~a" errors))))
 306
 307 (with-test (:name :pprint-circular-backq-comma)
 308   ;; LP 1161218 reported by James M. Lawrence
 309   (let ((string (write-to-string '(let ((#1=#:var '(99)))
 310                                    `(progn ,@(identity #1#)))
 311                                  :circle t :pretty t)))
 312     (assert (not (search "#2#" string)))))
 313
 314 (with-test (:name :pprint-dotted-setf)
 315   (let ((*print-pretty* t))
 316     (equal (format nil "~a" '(setf . a))
 317            "(SETF . A)")))
 318
 319 (with-test (:name :literal-fun-nested-lists)
 320   (assert (search "EQUALP" (format nil "~:w" `((((((,#'equalp)))))))
 321                   :test #'char-equal)))
 322 \f
 323 ;;; success