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 ;;; circular lists are still being printed correctly?
  32 (assert (equal
  33          (with-output-to-string (*standard-output*)
  34            (let ((*print-circle* t))
  35              (pprint-logical-block (*standard-output* *circ-list*)
  36                                  (format *standard-output* "~S" *circ-list*))))
  37          "#1=(1 . #1#)"))
  38
  39 ;;; test from CLHS
  40 (assert (equal
  41          (with-output-to-string (*standard-output*)
  42           (let ((a (list 1 2 3)))
  43             (setf (cdddr a) a)
  44             (let ((*print-circle* t))
  45               (write a :stream *standard-output*))
  46             :done))
  47          "#1=(1 2 3 . #1#)"))
  48
  49 ;;; test case 1 for bug 99
  50 (assert (equal
  51          (with-output-to-string (*standard-output*)
  52            (let* ((*print-circle* t))
  53              (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
  54                      'eql 'eql)))
  55          "EQL is EQL. This was not seen!"))
  56
  57 ;;; test case 2 for bug 99
  58 (assert (equal
  59          (with-output-to-string (*standard-output*)
  60            (let* ((*print-circle* t))
  61              (format *standard-output*
  62                      "~@<~S ~_is ~S and ~S. This was not seen!~:>"
  63                      'eql 'eql 'eql)))
  64          "EQL is EQL and EQL. This was not seen!"))
  65
  66 ;;; the original test for BUG 99 (only interactive), no obvious
  67 ;;; way to make an automated test:
  68 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
  69
  70 ;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
  71 ;;; PPRINT-LOGICAL-BLOCK may be complex strings
  72 (let ((list '(1 2 3))
  73       (prefix (make-array 2
  74                           :element-type 'character
  75                           :displaced-to ";x"
  76                           :fill-pointer 1))
  77       (suffix (make-array 2
  78                           :element-type 'character
  79                           :displaced-to ">xy"
  80                           :displaced-index-offset 1
  81                           :fill-pointer 1)))
  82   (assert (equal (with-output-to-string (s)
  83                    (pprint-logical-block (s list
  84                                             :per-line-prefix prefix
  85                                             :suffix suffix)
  86                      (format s "~{~W~^~:@_~}" list)))
  87                  (format nil ";1~%~
  88                               ;2~%~
  89                               ;3x"))))
  90
  91 ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
  92 ;;; from , .FOO and , @FOO
  93 (assert (equal
  94          (with-output-to-string (s)
  95            (write '`(,  .foo) :stream s :pretty t :readably t))
  96          "`(, .FOO)"))
  97 (assert (equal
  98          (with-output-to-string (s)
  99            (write '`(,  @foo) :stream s :pretty t :readably t))
 100          "`(, @FOO)"))
 101 (assert (equal
 102          (with-output-to-string (s)
 103            (write '`(,  ?foo) :stream s :pretty t :readably t))
 104          "`(,?FOO)"))
 105
 106 ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
 107 ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
 108 (assert (equal
 109          (with-output-to-string (s)
 110            (write '`(foo ,x) :stream s :pretty t :readably t))
 111          "`(FOO ,X)"))
 112 (assert (equal
 113          (with-output-to-string (s)
 114            (write '`(foo ,@x) :stream s :pretty t :readably t))
 115          "`(FOO ,@X)"))
 116 #+nil ; '`(foo ,.x) => '`(foo ,@x) apparently.
 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 '`(lambda ,x) :stream s :pretty t :readably t))
 124          "`(LAMBDA ,X)"))
 125 (assert (equal
 126          (with-output-to-string (s)
 127            (write '`(lambda ,@x) :stream s :pretty t :readably t))
 128          "`(LAMBDA ,@X)"))
 129 #+nil ; see above
 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 \f
 139 ;;; SET-PPRINT-DISPATCH should accept function name arguments
 140 (defun ppd-function-name (s o)
 141   (print (length o) s))
 142 (set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
 143 (let ((s (with-output-to-string (s)
 144            (pprint '(frob a b) s))))
 145   (assert (position #\3 s)))
 146 \f
 147 ;;; success
 148 (quit :unix-status 104)