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 (assert (multiple-value-bind (result error)
 116             (ignore-errors (read-from-string
 117                             (with-output-to-string (s)
 118                               (let ((*print-readably* t))
 119                                 (print (make-array '(1 0 1)) s)))))
 120           ;; it might not be readably-printable
 121           (or (typep error 'print-not-readable)
 122               ;; or else it had better have the same dimensions
 123               (equal (array-dimensions result) '(1 0 1)))))
 124
 125 ;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE
 126 (write #(1 2 3) :pretty nil :readably t)
 127
 128 ;;; another UNBOUND-VARIABLE, this time due to a bug in FORMATTER
 129 ;;; expanders.
 130 (funcall (formatter "~@<~A~:*~A~:>") nil 3)
 131
 132 ;;; the PPC floating point backend was at one point sufficiently
 133 ;;; broken that this looped infinitely or caused segmentation
 134 ;;; violations through stack corruption.
 135 (print 0.0001)
 136
 137 ;;; In sbcl-0.8.7, the ~W format directive interpreter implemented the
 138 ;;; sense of the colon and at-sign modifiers exactly backwards.
 139 ;;;
 140 ;;; (Yes, the test for this *is* substantially hairier than the fix;
 141 ;;; wanna make something of it?)
 142 (cl:in-package :cl-user)
 143 (defstruct wexerciser-0-8-7)
 144 (defun wexercise-0-8-7-interpreted (wformat)
 145   (format t wformat (make-wexerciser-0-8-7)))
 146 (defmacro define-compiled-wexercise-0-8-7 (wexercise wformat)
 147   `(defun ,wexercise ()
 148     (declare (optimize (speed 3) (space 1)))
 149     (format t ,wformat (make-wexerciser-0-8-7))
 150     (values)))
 151 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-without-atsign "~W")
 152 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-with-atsign "~@W")
 153 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 154   (unless (and *print-level* *print-length*)
 155     (error "gotcha coming")))
 156 (let ((*print-level* 11)
 157       (*print-length* 12))
 158   (wexercise-0-8-7-interpreted "~W")
 159   (wexercise-0-8-7-compiled-without-atsign))
 160 (remove-method #'print-object
 161                (find-method #'print-object
 162                             '(:before)
 163                             (mapcar #'find-class '(wexerciser-0-8-7 t))))
 164 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 165   (when (or *print-level* *print-length*)
 166     (error "gotcha going")))
 167 (let ((*print-level* 11)
 168       (*print-length* 12))
 169   (wexercise-0-8-7-interpreted "~@W")
 170   (wexercise-0-8-7-compiled-with-atsign))
 171 \f
 172 ;;; WRITE-TO-STRING was erroneously DEFKNOWNed as FOLDABLE
 173 ;;;
 174 ;;; This bug from PFD
 175 (defpackage "SCRATCH-WRITE-TO-STRING" (:use))
 176 (with-standard-io-syntax
 177   (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING"))
 178          (answer (write-to-string 'scratch-write-to-string::x :readably nil)))
 179     (assert (string= answer "X"))))
 180 ;;; and a couple from Bruno Haible
 181 (defun my-pprint-reverse (out list)
 182   (write-char #\( out)
 183   (when (setq list (reverse list))
 184     (loop
 185      (write (pop list) :stream out)
 186      (when (endp list) (return))
 187      (write-char #\Space out)))
 188   (write-char #\) out))
 189 (with-standard-io-syntax
 190   (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 191     (set-pprint-dispatch '(cons (member foo)) 'my-pprint-reverse 0)
 192     (let ((answer (write-to-string '(foo bar :boo 1) :pretty t :escape t)))
 193       (assert (string= answer "(1 :BOO BAR FOO)")))))
 194 (defun my-pprint-logical (out list)
 195   (pprint-logical-block (out list :prefix "(" :suffix ")")
 196     (when list
 197       (loop
 198        (write-char #\? out)
 199        (write (pprint-pop) :stream out)
 200        (write-char #\? out)
 201        (pprint-exit-if-list-exhausted)
 202        (write-char #\Space out)))))
 203 (with-standard-io-syntax
 204   (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 205     (set-pprint-dispatch '(cons (member bar)) 'my-pprint-logical 0)
 206     (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t)))
 207       (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)")))))
 208
 209 ;;; success
 210 (quit :unix-status 104)