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 ;;; success
 138 (quit :unix-status 104)