tests/print.impure.lisp

   1 ;;;; miscellaneous tests of printing stuff
   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 (load "assertoid.lisp")
  15 (use-package "ASSERTOID")
  16
  17 ;;; We should be able to output X readably (at least when *READ-EVAL*).
  18 (defun assert-readable-output (x)
  19   (assert (eql x
  20                (let ((*read-eval* t))
  21                  (read-from-string (with-output-to-string (s)
  22                                      (write x :stream s :readably t)))))))
  23
  24 ;;; Even when *READ-EVAL* is NIL, we should be able to output some
  25 ;;; (not necessarily readable) representation without signalling an
  26 ;;; error.
  27 (defun assert-unreadable-output (x)
  28   (let ((*read-eval* nil))
  29     (with-output-to-string (s) (write x :stream s :readably nil))))
  30
  31 (defun assert-output (x)
  32   (assert-readable-output x)
  33   (assert-unreadable-output x))
  34
  35 ;;; Nathan Froyd reported that sbcl-0.6.11.34 screwed up output of
  36 ;;; floating point infinities.
  37 (dolist (x (list short-float-positive-infinity short-float-negative-infinity
  38                  single-float-positive-infinity single-float-negative-infinity
  39                  double-float-positive-infinity double-float-negative-infinity
  40                  long-float-positive-infinity long-float-negative-infinity))
  41   (assert-output x))
  42
  43 ;;; Eric Marsden reported that this would blow up in CMU CL (even
  44 ;;; though ANSI says that the mismatch between ~F expected type and
  45 ;;; provided string type is supposed to be handled without signalling
  46 ;;; an error) and provided a fix which was ported to sbcl-0.6.12.35.
  47 (assert (null (format t "~F" "foo")))
  48
  49 ;;; This was a bug in SBCL until 0.6.12.40 (originally reported as a
  50 ;;; CMU CL bug by Erik Naggum on comp.lang.lisp).
  51 (loop for base from 2 to 36
  52       with *print-radix* = t
  53       do (let ((*print-base* base))
  54            (assert (string= "#*101" (format nil "~S" #*101)))))
  55
  56 ;;; bug in sbcl-0.7.1.25, reported by DB sbcl-devel 2002-02-25
  57 (assert (string= "0.5" (format nil "~2D" 0.5)))
  58
  59 ;;; we want malformed format strings to cause errors rather than have
  60 ;;; some DWIM "functionality".
  61 (assert (raises-error? (format nil "~:2T")))
  62
  63 ;;; bug reported, with fix, by Robert Strandh, sbcl-devel 2002-03-09,
  64 ;;; fixed in sbcl-0.7.1.36:
  65 (assert (string= (format nil "~2,3,8,'0$" 1234567.3d0) "1234567.30"))
  66
  67 ;;; checks that other FORMAT-DOLLAR output remains sane after the
  68 ;;; 0.7.1.36 change
  69 (assert (string= (format nil "~$" 0) "0.00"))
  70 (assert (string= (format nil "~$" 4) "4.00"))
  71 (assert (string= (format nil "~$" -4.0) "-4.00"))
  72 (assert (string= (format nil "~2,7,11$" -4.0) "-0000004.00"))
  73 (assert (string= (format nil "~2,7,11,' $" 1.1) " 0000001.10"))
  74 (assert (string= (format nil "~1,7,11,' $" 1.1) "  0000001.1"))
  75 (assert (string= (format nil "~1,3,8,' $" 7.3) "   007.3"))
  76 (assert (string= (format nil "~2,3,8,'0$" 7.3) "00007.30"))
  77
  78 ;;; Check for symbol lookup in ~/ / directive -- double-colon was
  79 ;;; broken in 0.7.1.36 and earlier
  80 (defun print-foo (stream arg colonp atsignp &rest params)
  81   (declare (ignore colonp atsignp params))
  82   (format stream "~d" arg))
  83
  84 (assert (string= (format nil "~/print-foo/" 2) "2"))
  85 (assert (string= (format nil "~/cl-user:print-foo/" 2) "2"))
  86 (assert (string= (format nil "~/cl-user::print-foo/" 2) "2"))
  87 (assert (raises-error? (format nil "~/cl-user:::print-foo/" 2)))
  88 (assert (raises-error? (format nil "~/cl-user:a:print-foo/" 2)))
  89 (assert (raises-error? (format nil "~/a:cl-user:print-foo/" 2)))
  90 (assert (raises-error? (format nil "~/cl-user:print-foo:print-foo/" 2)))
  91
  92 ;;; better make sure that we get this one right, too
  93 (defun print-foo\:print-foo (stream arg colonp atsignp &rest params)
  94   (declare (ignore colonp atsignp params))
  95   (format stream "~d" arg))
  96
  97 (assert (string= (format nil "~/cl-user:print-foo:print-foo/" 2) "2"))
  98 (assert (string= (format nil "~/cl-user::print-foo:print-foo/" 2) "2"))
  99
 100 ;;; Check for error detection of illegal directives in a~<..~> justify
 101 ;;; block (see ANSI section 22.3.5.2)
 102 (assert (raises-error? (format nil "~<~W~>" 'foo)))
 103 (assert (raises-error? (format nil "~<~<~A~:>~>" '(foo))))
 104 (assert (string= (format nil "~<~<~A~>~>" 'foo) "FOO"))
 105
 106 ;;; Check that arrays that we print while *PRINT-READABLY* is true are
 107 ;;; in fact generating similar objects.
 108 (assert (equal (array-dimensions
 109                 (read-from-string
 110                  (with-output-to-string (s)
 111                    (let ((*print-readably* t))
 112                      (print (make-array '(1 2 0)) s)))))
 113                '(1 2 0)))
 114
 115 (dolist (array (list (make-array '(1 0 1))
 116                      (make-array 0 :element-type nil)
 117                      (make-array 1 :element-type 'base-char)
 118                      (make-array 1 :element-type 'character)))
 119   (assert (multiple-value-bind (result error)
 120               (ignore-errors (read-from-string
 121                               (with-output-to-string (s)
 122                                 (let ((*print-readably* t))
 123                                   (print array s)))))
 124             ;; it might not be readably-printable
 125             (or (typep error 'print-not-readable)
 126                 (and
 127                  ;; or else it had better have the same dimensions
 128                  (equal (array-dimensions result) (array-dimensions array))
 129                  ;; and the same element-type
 130                  (equal (array-element-type result) (array-element-type array)))))))
 131
 132 ;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE
 133 (write #(1 2 3) :pretty nil :readably t)
 134
 135 ;;; another UNBOUND-VARIABLE, this time due to a bug in FORMATTER
 136 ;;; expanders.
 137 (funcall (formatter "~@<~A~:*~A~:>") nil 3)
 138
 139 ;;; the PPC floating point backend was at one point sufficiently
 140 ;;; broken that this looped infinitely or caused segmentation
 141 ;;; violations through stack corruption.
 142 (print 0.0001)
 143
 144 ;;; In sbcl-0.8.7, the ~W format directive interpreter implemented the
 145 ;;; sense of the colon and at-sign modifiers exactly backwards.
 146 ;;;
 147 ;;; (Yes, the test for this *is* substantially hairier than the fix;
 148 ;;; wanna make something of it?)
 149 (cl:in-package :cl-user)
 150 (defstruct wexerciser-0-8-7)
 151 (defun wexercise-0-8-7-interpreted (wformat)
 152   (format t wformat (make-wexerciser-0-8-7)))
 153 (defmacro define-compiled-wexercise-0-8-7 (wexercise wformat)
 154   `(defun ,wexercise ()
 155     (declare (optimize (speed 3) (space 1)))
 156     (format t ,wformat (make-wexerciser-0-8-7))
 157     (values)))
 158 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-without-atsign "~W")
 159 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-with-atsign "~@W")
 160 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 161   (unless (and *print-level* *print-length*)
 162     (error "gotcha coming")))
 163 (let ((*print-level* 11)
 164       (*print-length* 12))
 165   (wexercise-0-8-7-interpreted "~W")
 166   (wexercise-0-8-7-compiled-without-atsign))
 167 (remove-method #'print-object
 168                (find-method #'print-object
 169                             '(:before)
 170                             (mapcar #'find-class '(wexerciser-0-8-7 t))))
 171 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 172   (when (or *print-level* *print-length*)
 173     (error "gotcha going")))
 174 (let ((*print-level* 11)
 175       (*print-length* 12))
 176   (wexercise-0-8-7-interpreted "~@W")
 177   (wexercise-0-8-7-compiled-with-atsign))
 178 \f
 179 ;;; WRITE-TO-STRING was erroneously DEFKNOWNed as FOLDABLE
 180 ;;;
 181 ;;; This bug from PFD
 182 (defpackage "SCRATCH-WRITE-TO-STRING" (:use))
 183 (with-standard-io-syntax
 184   (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING"))
 185          (answer (write-to-string 'scratch-write-to-string::x :readably nil)))
 186     (assert (string= answer "X"))))
 187 ;;; and a couple from Bruno Haible
 188 (defun my-pprint-reverse (out list)
 189   (write-char #\( out)
 190   (when (setq list (reverse list))
 191     (loop
 192      (write (pop list) :stream out)
 193      (when (endp list) (return))
 194      (write-char #\Space out)))
 195   (write-char #\) out))
 196 (with-standard-io-syntax
 197   (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 198     (set-pprint-dispatch '(cons (member foo)) 'my-pprint-reverse 0)
 199     (let ((answer (write-to-string '(foo bar :boo 1) :pretty t :escape t)))
 200       (assert (string= answer "(1 :BOO BAR FOO)")))))
 201 (defun my-pprint-logical (out list)
 202   (pprint-logical-block (out list :prefix "(" :suffix ")")
 203     (when list
 204       (loop
 205        (write-char #\? out)
 206        (write (pprint-pop) :stream out)
 207        (write-char #\? out)
 208        (pprint-exit-if-list-exhausted)
 209        (write-char #\Space out)))))
 210 (with-standard-io-syntax
 211   (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 212     (set-pprint-dispatch '(cons (member bar)) 'my-pprint-logical 0)
 213     (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t)))
 214       (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)")))))
 215
 216 ;;; FORMAT string compile-time checker failure, reported by Thomas
 217 ;;; F. Burdick
 218 (multiple-value-bind (f w-p f-p)
 219     (compile nil '(lambda () (format nil "~{")))
 220   (assert (and w-p f-p))
 221   (assert (nth-value 1 (ignore-errors (funcall f)))))
 222
 223 ;;; floating point print/read consistency
 224 (let ((x (/ -9.349640046247849d-21 -9.381494249123696d-11)))
 225   (let ((y (read-from-string (write-to-string x :readably t))))
 226     (assert (eql x y))))
 227
 228 (let ((x1 (float -5496527/100000000000000000))
 229       (x2 (float -54965272/1000000000000000000)))
 230   (assert (or (equal (multiple-value-list (integer-decode-float x1))
 231                      (multiple-value-list (integer-decode-float x2)))
 232               (string/= (prin1-to-string x1) (prin1-to-string x2)))))
 233
 234 ;;; readable printing of arrays with *print-radix* t
 235 (let ((*print-radix* t)
 236       (*print-readably* t)
 237       (*print-pretty* nil))
 238   (let ((output (with-output-to-string (s)
 239                   (write #2a((t t) (nil nil)) :stream s))))
 240     (assert (equalp (read-from-string output) #2a((t t) (nil nil))))))
 241
 242 ;;; success
 243 (quit :unix-status 104)