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 (with-test (:name (write float :infinities))
  38   (dolist (x (list short-float-positive-infinity short-float-negative-infinity
  39                    single-float-positive-infinity single-float-negative-infinity
  40                    double-float-positive-infinity double-float-negative-infinity
  41                    long-float-positive-infinity long-float-negative-infinity))
  42     (assert-output x)))
  43
  44 ;;; Eric Marsden reported that this would blow up in CMU CL (even
  45 ;;; though ANSI says that the mismatch between ~F expected type and
  46 ;;; provided string type is supposed to be handled without signalling
  47 ;;; an error) and provided a fix which was ported to sbcl-0.6.12.35.
  48 (with-test (:name (format :fixed-format-floating-point-directive :type-mismatch))
  49   (let ((*standard-output* (make-broadcast-stream)))
  50     (assert (null (format t "~F" "foo")))))
  51
  52 ;;; This was a bug in SBCL until 0.6.12.40 (originally reported as a
  53 ;;; CMU CL bug by Erik Naggum on comp.lang.lisp).
  54 (with-test (:name (format bit-vector *print-base* *print-radix*))
  55   (loop for base from 2 to 36
  56      with *print-radix* = t
  57      do (let ((*print-base* base))
  58           (assert (string= "#*101" (format nil "~S" #*101))))))
  59
  60 ;;; bug in sbcl-0.7.1.25, reported by DB sbcl-devel 2002-02-25
  61 (with-test (:name (:format :decimal-directive :type-mismatch))
  62   (assert (string= "0.5" (format nil "~2D" 0.5))))
  63
  64 ;;; we want malformed format strings to cause errors rather than have
  65 ;;; some DWIM "functionality".
  66 (with-test (:name (format :tabulate-directive :malformed))
  67   (multiple-value-bind (fun failure-p warnings)
  68       (checked-compile `(lambda () (format nil "~:2T"))
  69                        :allow-failure t :allow-warnings t)
  70     (assert failure-p)
  71     (assert (= 1 (length warnings)))
  72     (assert-error (funcall fun))))
  73
  74 ;;; bug reported, with fix, by Robert Strandh, sbcl-devel 2002-03-09,
  75 ;;; fixed in sbcl-0.7.1.36:
  76 (with-test (:name (format :monetary-floating-point-directive 1))
  77   (assert (string= (format nil "~2,3,8,'0$" 1234567.3d0) "1234567.30")))
  78
  79 ;;; checks that other FORMAT-DOLLAR output remains sane after the
  80 ;;; 0.7.1.36 change
  81 (with-test (:name (format :monetary-floating-point-directive 2))
  82   (assert (string= (format nil "~$" 0) "0.00"))
  83   (assert (string= (format nil "~$" 4) "4.00"))
  84   (assert (string= (format nil "~$" -4.0) "-4.00"))
  85   (assert (string= (format nil "~2,7,11$" -4.0) "-0000004.00"))
  86   (assert (string= (format nil "~2,7,11,' $" 1.1) " 0000001.10"))
  87   (assert (string= (format nil "~1,7,11,' $" 1.1) "  0000001.1"))
  88   (assert (string= (format nil "~1,3,8,' $" 7.3) "   007.3"))
  89   (assert (string= (format nil "~2,3,8,'0$" 7.3) "00007.30")))
  90
  91 ;;; Check for symbol lookup in ~/ / directive -- double-colon was
  92 ;;; broken in 0.7.1.36 and earlier
  93 (defun print-foo (stream arg colonp atsignp &rest params)
  94   (declare (ignore colonp atsignp params))
  95   (format stream "~d" arg))
  96
  97 (with-test (:name (format :call-function-directive :smoke))
  98   (assert (string= (format nil "~/print-foo/" 2) "2"))
  99   (assert (string= (format nil "~/cl-user:print-foo/" 2) "2"))
 100   (assert (string= (format nil "~/cl-user::print-foo/" 2) "2")))
 101
 102 (with-test (:name (format :call-function-directive :syntax-errors))
 103   (flet ((test (args)
 104            (multiple-value-bind (fun failure-p)
 105                (checked-compile `(lambda (format nil ,@args))
 106                                 :allow-failure t)
 107              (assert failure-p)
 108              (assert-error (funcall fun)))))
 109     (test '("~/cl-user:::print-foo/" 2))
 110     (test '("~/cl-user:a:print-foo/" 2))
 111     (test '("~/a:cl-user:print-foo/" 2))
 112     (test '("~/cl-user:print-foo:print-foo/" 2))))
 113
 114 ;;; better make sure that we get this one right, too
 115 (defun print-foo\:print-foo (stream arg colonp atsignp &rest params)
 116   (declare (ignore colonp atsignp params))
 117   (format stream "~d" arg))
 118
 119 (with-test (:name (format :call-function-directive :colon-in-function-name))
 120   (assert (string= (format nil "~/cl-user:print-foo:print-foo/" 2) "2"))
 121   (assert (string= (format nil "~/cl-user::print-foo:print-foo/" 2) "2")))
 122
 123 ;;; Check for error detection of illegal directives in a~<..~> justify
 124 ;;; block (see ANSI section 22.3.5.2)
 125 (with-test (:name (format :justification-directive :illegal-directives))
 126   (flet ((test (args)
 127            (multiple-value-bind (fun failure-p)
 128                (checked-compile `(lambda () (format nil ,@args))
 129                                 :allow-failure t)
 130              (assert failure-p)
 131              (assert-error (funcall fun)))))
 132     (test '("~<~W~>" 'foo))
 133     (test '("~<~<~A~:>~>" '(foo))))
 134   (assert (string= (format nil "~<~<~A~>~>" 'foo) "FOO")))
 135
 136 (with-test (:name (format :justification-directive :atsign-check))
 137   (multiple-value-bind (fun failure-p)
 138       (checked-compile `(lambda () (format nil "~<~@>"))
 139                        :allow-failure t)
 140     (assert failure-p)
 141     (assert-error (funcall fun)))
 142   (assert-error (eval '(format nil "~<~@>"))))
 143
 144 ;;; Check that arrays that we print while *PRINT-READABLY* is true are
 145 ;;; in fact generating similar objects.
 146 (with-test (:name (print array *print-readably* :dimensions))
 147   (assert (equal (array-dimensions
 148                   (read-from-string
 149                    (with-output-to-string (s)
 150                      (let ((*print-readably* t))
 151                        (print (make-array '(1 2 0)) s)))))
 152                  '(1 2 0))))
 153
 154 (with-test (:name (print array *print-readably* :element-type))
 155   (dolist (array (list (make-array '(1 0 1))
 156                        (make-array 0 :element-type nil)
 157                        (make-array 1 :element-type 'base-char)
 158                        (make-array 1 :element-type 'character)))
 159     (assert (multiple-value-bind (result error)
 160                 (ignore-errors (read-from-string
 161                                 (with-output-to-string (s)
 162                                   (let ((*print-readably* t))
 163                                     (print array s)))))
 164               ;; it might not be readably-printable
 165               (or (typep error 'print-not-readable)
 166                   (and
 167                    ;; or else it had better have the same dimensions
 168                    (equal (array-dimensions result) (array-dimensions array))
 169                    ;; and the same element-type
 170                    (equal (array-element-type result) (array-element-type array))))))))
 171
 172 ;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE
 173 (with-test (:name (write vector :smoke))
 174   (let ((*standard-output* (make-broadcast-stream)))
 175     (write #(1 2 3) :pretty nil :readably t)))
 176
 177 ;;; another UNBOUND-VARIABLE, this time due to a bug in FORMATTER
 178 ;;; expanders.
 179 (with-test (:name (formatter :smoke))
 180   (funcall (formatter "~@<~A~:*~A~:>") (make-broadcast-stream) 3))
 181
 182 ;;; the PPC floating point backend was at one point sufficiently
 183 ;;; broken that this looped infinitely or caused segmentation
 184 ;;; violations through stack corruption.
 185 (with-test (:name (print float :smoke))
 186   (let ((*standard-output* (make-broadcast-stream)))
 187     (print 0.0001)))
 188
 189 ;;; In sbcl-0.8.7, the ~W format directive interpreter implemented the
 190 ;;; sense of the colon and at-sign modifiers exactly backwards.
 191 ;;;
 192 ;;; (Yes, the test for this *is* substantially hairier than the fix;
 193 ;;; wanna make something of it?)
 194 (cl:in-package :cl-user)
 195 (defstruct wexerciser-0-8-7)
 196 (defun wexercise-0-8-7-interpreted (wformat)
 197   (format t wformat (make-wexerciser-0-8-7)))
 198 (defmacro define-compiled-wexercise-0-8-7 (wexercise wformat)
 199   `(defun ,wexercise ()
 200     (declare (optimize (speed 3) (space 1)))
 201     (format t ,wformat (make-wexerciser-0-8-7))
 202     (values)))
 203 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-without-atsign "~W")
 204 (define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-with-atsign "~@W")
 205 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 206   (unless (and *print-level* *print-length*)
 207     (error "gotcha coming")))
 208 (with-test (:name (format :write-directive :colon :at-sign 1))
 209   (let ((*print-level* 11)
 210         (*print-length* 12)
 211         (*standard-output* (make-broadcast-stream)))
 212     (wexercise-0-8-7-interpreted "~W")
 213     (wexercise-0-8-7-compiled-without-atsign)))
 214 (remove-method #'print-object
 215                (find-method #'print-object
 216                             '(:before)
 217                             (mapcar #'find-class '(wexerciser-0-8-7 t))))
 218 (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
 219   (when (or *print-level* *print-length*)
 220     (error "gotcha going")))
 221 (with-test (:name (format :write-directive :colon :at-sign 2))
 222   (let ((*print-level* 11)
 223         (*print-length* 12)
 224         (*standard-output* (make-broadcast-stream)))
 225     (wexercise-0-8-7-interpreted "~@W")
 226     (wexercise-0-8-7-compiled-with-atsign)))
 227 \f
 228 ;;; WRITE-TO-STRING was erroneously DEFKNOWNed as FOLDABLE
 229
 230 ;;; This bug from PFD
 231 (defpackage "SCRATCH-WRITE-TO-STRING" (:use))
 232 (with-test (:name (write symbol *package*))
 233   (with-standard-io-syntax
 234     (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING"))
 235            (answer (write-to-string 'scratch-write-to-string::x :readably nil)))
 236       (assert (string= answer "X")))))
 237
 238 ;;; and a couple from Bruno Haible
 239 (defun my-pprint-reverse (out list)
 240   (write-char #\( out)
 241   (when (setq list (reverse list))
 242     (loop
 243      (write (pop list) :stream out)
 244      (when (endp list) (return))
 245      (write-char #\Space out)))
 246   (write-char #\) out))
 247 (with-test (:name (write *print-pprint-dispatch* 1))
 248   (with-standard-io-syntax
 249     (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 250       (set-pprint-dispatch '(cons (member foo)) 'my-pprint-reverse 0)
 251       (let ((answer (write-to-string '(foo bar :boo 1) :pretty t :escape t)))
 252         (assert (string= answer "(1 :BOO BAR FOO)"))))))
 253
 254 (defun my-pprint-logical (out list)
 255   (pprint-logical-block (out list :prefix "(" :suffix ")")
 256     (when list
 257       (loop
 258        (write-char #\? out)
 259        (write (pprint-pop) :stream out)
 260        (write-char #\? out)
 261        (pprint-exit-if-list-exhausted)
 262        (write-char #\Space out)))))
 263 (with-test (:name (write *print-pprint-dispatch* 2))
 264   (with-standard-io-syntax
 265     (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
 266       (set-pprint-dispatch '(cons (member bar)) 'my-pprint-logical 0)
 267       (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t)))
 268         (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)"))))))
 269
 270 ;;; FORMAT string compile-time checker failure, reported by Thomas
 271 ;;; F. Burdick
 272 (with-test (:name (format :compile-time-check))
 273   (multiple-value-bind (fun failure-p warnings)
 274       (checked-compile '(lambda () (format nil "~{"))
 275                        :allow-failure t :allow-warnings t)
 276     (assert failure-p)
 277     (assert (= (length warnings) 1))
 278     (assert-error (funcall fun))))
 279
 280 ;;; floating point print/read consistency
 281 (with-test (:name (read print float :consistency))
 282   (let* ((x (/ -9.349640046247849d-21 -9.381494249123696d-11))
 283          (y (read-from-string (write-to-string x :readably t))))
 284     (assert (eql x y)))
 285
 286   (let ((x1 (float -5496527/100000000000000000))
 287         (x2 (float -54965272/1000000000000000000)))
 288     (assert (or (equal (multiple-value-list (integer-decode-float x1))
 289                        (multiple-value-list (integer-decode-float x2)))
 290                 (string/= (prin1-to-string x1) (prin1-to-string x2))))))
 291
 292 ;;; readable printing of arrays with *print-radix* t
 293 (with-test (:name (write read array *print-radix*))
 294   (let ((*print-radix* t)
 295         (*print-readably* t)
 296         (*print-pretty* nil))
 297     (let ((output (with-output-to-string (s)
 298                     (write #2a((t t) (nil nil)) :stream s))))
 299       (assert (equalp (read-from-string output) #2a((t t) (nil nil)))))))
 300
 301 ;;; NIL parameters to "interpreted" FORMAT directives
 302 (with-test (:name (format :v-directive-arg nil))
 303  (assert (string= (format nil "~v%" nil) (string #\Newline))))
 304
 305 ;;; PRINC-TO-STRING should bind print-readably
 306 (with-test (:name (princ-to-string *print-readably*))
 307   (let ((*print-readably* t))
 308     (assert (string= (princ-to-string #\7)
 309                      (write-to-string #\7 :escape nil :readably nil)))))
 310
 311 ;;; in FORMAT, ~^ inside ~:{ should go to the next case, not break
 312 ;;; iteration, even if one argument is just a one-element list.
 313 (with-test (:name (format :escape-upward-directive :in :iteration-directive))
 314   (assert (string= (format nil "~:{~A~^~}" '((A) (C D))) "AC")))
 315
 316 ;;; errors should be signaled if pprint and justification are mixed
 317 ;;; injudiciously...
 318 (with-test (:name (format :mixing :justification-directive :pprint-directives :illegal))
 319   (dolist (x (list "~<~:;~>~_" "~<~:;~>~I" "~<~:;~>~W"
 320                    "~<~:;~>~:T" "~<~:;~>~<~:>" "~_~<~:;~>"
 321                    "~I~<~:;~>" "~W~<~:;~>" "~:T~<~:;~>" "~<~:>~<~:;~>"))
 322     (assert-error (format nil x nil))
 323     (assert-error (format nil (eval `(formatter ,x)) nil))))
 324 ;;; ...but not in judicious cases.
 325 (with-test (:name (format :mixing :justification-directive :pprint-directives :legal))
 326   (dolist (x (list "~<~;~>~_" "~<~;~>~I" "~<~;~>~W"
 327                    "~<~;~>~:T" "~<~;~>~<~>" "~_~<~;~>"
 328                    "~I~<~;~>" "~W~<~;~>" "~:T~<~;~>" "~<~>~<~;~>"
 329                    "~<~:;~>~T" "~T~<~:;~>"))
 330     (assert (format nil x nil))
 331     (assert (format nil (eval `(formatter ,x)) nil))))
 332
 333 ;;; bug 350: bignum printing so memory-hungry that heap runs out
 334 ;;; -- just don't stall here forever on a slow box
 335 (with-test (:name :bug-350)
 336   (handler-case
 337       (with-timeout 10
 338         (print (ash 1 1000000) (make-broadcast-stream)))
 339     (timeout ()
 340       (print 'timeout!))))
 341
 342 ;;; bug 371: bignum print/read inconsistency
 343 (defvar *bug-371* -7043009959286724629649270926654940933664689003233793014518979272497911394287216967075767325693021717277238746020477538876750544587281879084559996466844417586093291189295867052594478662802691926547232838591510540917276694295393715934079679531035912244103731582711556740654671309980075069010778644542022/670550434139267031632063192770201289106737062379324644110801846820471752716238484923370056920388400273070254958650831435834503195629325418985020030706879602898158806736813101434594805676212779217311897830937606064579213895527844045511878668289820732425014254579493444623868748969110751636786165152601)
 344 (with-test (:name (read print bignum :consistency :bug-371))
 345   (let ((*print-base* 5)
 346         (*read-base* 5)
 347         (*print-radix* nil))
 348     (assert (= *bug-371* (read-from-string (prin1-to-string *bug-371*))))))
 349
 350 ;;; a spot of random-testing for rational printing
 351 (defvar *seed-state* (make-random-state))
 352 (with-open-file (f "last-random-state.lisp-expr"
 353                    :direction :output :if-exists :supersede)
 354   ;; I don't want to see this every time
 355   (write *seed-state* :pretty nil :stream f)) ; so that we can reproduce errors
 356 (with-test (:name (read print rational :consistency ))
 357   (let ((seed (make-random-state *seed-state*)))
 358     (loop repeat 42
 359        do (let ((n (random (ash 1 1000) seed))
 360                 (d (random (ash 1 1000) seed)))
 361             (when (zerop (random 2 seed))
 362               (setf n (- n)))
 363             (let ((r (/ n d)))
 364               (loop for base from 2 to 36
 365                  do (let ((*print-base* base)
 366                           (*read-base* base)
 367                           (*print-radix* nil))
 368                       (assert (= r (read-from-string (prin1-to-string r))))
 369                       (if (= 36 base)
 370                           (decf *read-base*)
 371                           (incf *read-base*))
 372                       (assert (not (eql r (read-from-string (prin1-to-string r)))))
 373                       (let ((*print-radix* t))
 374                         (assert (= r (read-from-string
 375                                       (princ-to-string r)))))))))
 376          (write-char #\.)
 377          (finish-output))))
 378
 379 ;;;; Bugs, found by PFD
 380 ;;; NIL parameter for ~^ means `not supplied'
 381 (with-test (:name (format :escape-upward-directive :v-directive-arg nil))
 382   (loop for (format arg result) in
 383        '(("~:{~D~v^~D~}" ((3 1 4) (1 0 2) (7 nil) (5 nil 6)) "341756")
 384          ("~:{~1,2,v^~A~}" ((nil 0) (3 1) (0 2)) "02"))
 385      do (assert (string= (funcall #'format nil format arg) result))
 386      do (assert (string= (with-output-to-string (s)
 387                            (funcall (eval `(formatter ,format)) s arg))
 388                          result))))
 389
 390 ;;; NIL first parameter for ~R is equivalent to no parameter.
 391 (with-test (:name (format :radix-directive nil :argument))
 392   (assert (string= (format nil "~VR" nil 5) "five"))
 393   (assert (string= (format nil (formatter "~VR") nil 6) "six")))
 394
 395 ;;; CSR inserted a bug into Burger & Dybvig's float printer.  Caught
 396 ;;; by Raymond Toy
 397 (with-test (:name (format :exponential-floating-point-directive :smoke))
 398   (assert (string= (format nil "~E" 1d23) "1.d+23")))
 399
 400 ;;; Fixed-format bugs from CLISP's test suite (reported by Bruno
 401 ;;; Haible, bug 317)
 402 (with-test (:name (format :fixed-format-floating-point-directive :bug-317))
 403  (assert (string= (format nil "~1F" 10) "10."))
 404  (assert (string= (format nil "~0F" 10) "10."))
 405  (assert (string= (format nil "~2F" 1234567.1) "1234567.")))
 406
 407 ;;; here's one that seems to fail most places.  I think this is right,
 408 ;;; and most of the other answers I've seen are definitely wrong.
 409 (with-test (:name (format :general-floating-point-directive :smoke))
 410   (assert (string= (format nil "~G" 1d23) "100000000000000000000000.    ")))
 411
 412 ;;; Adam Warner's test case
 413 (with-test (:name (format :fixed-format-floating-point-directive :at-sign))
 414   (assert (string= (format nil "~@F" 1.23) "+1.23")))
 415
 416
 417 ;;; New (2005-11-08, also known as CSR House day) float format test
 418 ;;; cases.  Simon Alexander, Raymond Toy, and others
 419 (with-test (:name (format :floating-point-directives :misc))
 420   (assert (string= (format nil "~9,4,,-7E" pi) ".00000003d+8"))
 421   (assert (string= (format nil "~9,4,,-5E" pi) ".000003d+6"))
 422   (assert (string= (format nil "~5,4,,7E" pi) "3141600.d-6"))
 423   (assert (string= (format nil "~11,4,,3E" pi) "  314.16d-2"))
 424   (assert (string= (format nil "~11,4,,5E" pi) "  31416.d-4"))
 425   (assert (string= (format nil "~11,4,,0E" pi) "  0.3142d+1"))
 426   (assert (string= (format nil "~9,,,-1E" pi) ".03142d+2"))
 427   (assert (string= (format nil "~,,,-2E" pi) "0.003141592653589793d+3"))
 428   (assert (string= (format nil "~,,,2E" pi) "31.41592653589793d-1"))
 429   (assert (string= (format nil "~E" pi) "3.141592653589793d+0"))
 430   (assert (string= (format nil "~9,5,,-1E" pi) ".03142d+2"))
 431   (assert (string= (format nil "~11,5,,-1E" pi) " 0.03142d+2"))
 432   (assert (string= (format nil "~G" pi) "3.141592653589793    "))
 433   (assert (string= (format nil "~9,5G" pi) "3.1416    "))
 434   (assert (string= (format nil "|~13,6,2,7E|" pi) "| 3141593.d-06|"))
 435   (assert (string= (format nil "~9,3,2,0,'%E" pi) "0.314d+01"))
 436   (assert (string= (format nil "~9,0,6f" pi) " 3141593."))
 437   (assert (string= (format nil "~6,2,1,'*F" pi) " 31.42"))
 438   (assert (string= (format nil "~6,2,1,'*F" (* 100 pi)) "******"))
 439   (assert (string= (format nil "~9,3,2,-2,'%@E" pi) "+.003d+03"))
 440   (assert (string= (format nil "~10,3,2,-2,'%@E" pi) "+0.003d+03"))
 441   (assert (string= (format nil "~15,3,2,-2,'%,'=@E" pi) "=====+0.003d+03"))
 442   (assert (string= (format nil "~9,3,2,-2,'%E" pi) "0.003d+03"))
 443   (assert (string= (format nil "~8,3,2,-2,'%@E" pi) "%%%%%%%%"))
 444
 445   (assert (string= (format nil "~g" 1e0) "1.    "))
 446   (assert (string= (format nil "~g" 1.2d40) "12000000000000000000000000000000000000000.    "))
 447
 448   (assert (string= (format nil "~e" 0) "0.0e+0"))
 449   (assert (string= (format nil "~e" 0d0) "0.0d+0"))
 450   (assert (string= (format nil "~9,,4e" 0d0) "0.0d+0000")))
 451
 452 (with-test (:name (print hash-table print-not-readable))
 453   (let ((table (make-hash-table)))
 454     (setf (gethash 1 table) t)
 455     (assert-error (with-standard-io-syntax
 456                     (let ((*read-eval* nil)
 457                           (*print-readably* t))
 458                       (with-output-to-string (*standard-output*)
 459                         (prin1 table))))
 460                   print-not-readable)))
 461
 462 ;; Test that we can print characters readably regardless of the external format
 463 ;; of the stream.
 464
 465 (defun test-readable-character (character external-format)
 466   (let ((file "print.impure.tmp"))
 467     (unwind-protect
 468          (progn
 469            (with-open-file (stream file
 470                                    :direction :output
 471                                    :external-format external-format
 472                                    :if-exists :supersede)
 473              (write character :stream stream :readably t))
 474            (with-open-file (stream file
 475                                    :direction :input
 476                                    :external-format external-format
 477                                    :if-does-not-exist :error)
 478              (assert (char= (read stream) character))))
 479       (ignore-errors
 480         (delete-file file)))))
 481
 482 (with-test (:name (:print-readable :character :utf-8) :skipped-on '(not :sb-unicode))
 483   (test-readable-character (code-char #xfffe) :utf-8))
 484
 485 (with-test (:name (:print-readable :character :iso-8859-1) :skipped-on '(not :sb-unicode))
 486   (test-readable-character (code-char #xfffe) :iso-8859-1))
 487
 488 (with-test (:name (format :character-directive :colon))
 489   (assert (string= (eval '(format nil "~:C" #\a)) "a"))
 490   (assert (string= (format nil (formatter "~:C") #\a) "a")))
 491
 492 ;;; This used to trigger an AVER instead.
 493 (with-test (:name (format :end-of-justification-directive :mismatch))
 494   (assert-error (eval '(formatter "~>")) sb-format:format-error)
 495   (assert-error (eval '(format t "~>")) sb-format:format-error))
 496
 497 ;;; readably printing hash-tables, check for circularity
 498 (with-test (:name (print read hash-table *print-circle*))
 499   (let ((x (cons 1 2))
 500         (h (make-hash-table))
 501         (*print-readably* t)
 502         (*print-circle* t)
 503         (*read-eval* t))
 504     (setf (gethash x h) h)
 505     (destructuring-bind (x2 . h2) (read-from-string (write-to-string (cons x h)))
 506       (assert (equal x x2))
 507       (assert (eq h2 (gethash x2 h2))))))
 508
 509 ;;; an off-by-one error in the ~R format directive until 1.0.15.20
 510 ;;; prevented printing cardinals and ordinals between (expt 10 63) and
 511 ;;; (1- (expt 10 66))
 512 (with-test (:name (format :radix-directive :large-values))
 513   (assert (string= (format nil "~R" (expt 10 63)) "one vigintillion"))
 514   (assert (string= (format nil "~:R" (expt 10 63)) "one vigintillionth")))
 515
 516 ;;; too-clever cacheing for PRINT-OBJECT resulted in a bogus method
 517 ;;; for printing RESTART objects.  Check also CONTROL-STACK-EXHAUSTED
 518 ;;; and HEAP-EXHAUSTED-ERROR.
 519 (with-test (:name (print-object restart condition))
 520   (let ((result (with-output-to-string (*standard-output*)
 521                   (princ (find-restart 'abort)))))
 522     (assert (string/= result "#<" :end1 2)))
 523   (let ((result (with-output-to-string (*standard-output*)
 524                   (princ (make-condition 'sb-kernel::control-stack-exhausted)))))
 525     (assert (string/= result "#<" :end1 2)))
 526   (let ((result (with-output-to-string (*standard-output*)
 527                   (princ (make-condition 'sb-kernel::heap-exhausted-error)))))
 528     (assert (string/= result "#<" :end1 2))))
 529
 530 (with-test (:name (:with-standard-io-syntax :bind-print-pprint-dispatch))
 531   (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)))
 532     (set-pprint-dispatch 'symbol #'(lambda (stream obj)
 533                                      (declare (ignore obj))
 534                                      (write-string "FOO" stream)))
 535     (with-standard-io-syntax
 536       (let ((*print-pretty* t))
 537         (assert (string= (princ-to-string 'bar) "BAR"))))))
 538
 539 ;;; lp#1398290 (which obsoletes lp#488979)
 540
 541 (defclass a-class-name () ())
 542
 543 (with-test (:name :print-unreadable-no-conditional-newline)
 544   (assert (not (find #\Newline
 545                      (let ((*print-pretty* t)
 546                            (*print-right-margin* 10))
 547                        (format nil "~A" (make-instance 'a-class-name)))
 548                      :test #'char=)))
 549
 550   (assert (not (find #\Newline
 551                      (let ((*print-pretty* nil)
 552                            (*print-right-margin* 10))
 553                        (format nil "~A" (make-instance 'a-class-name)))
 554                      :test #'char=))))
 555
 556 ;;; The PRINT-OBJECT method for RANDOM-STATE used to have a bogus
 557 ;;; dimension argument for MAKE-ARRAY.
 558 (with-test (:name :print-random-state)
 559   (assert (equalp *random-state*
 560                   (read-from-string
 561                    (write-to-string *random-state*)))))
 562
 563 (with-test (:name :write-return-value)
 564   ;; COMPILE is called explicitly because there was a bug in the
 565   ;; compiler-macro for WRITE, which isn't expanded by the evaluator.
 566   (assert (= 123 (funcall (checked-compile '(lambda (s) (write 123 :stream s)))
 567                           (make-broadcast-stream)))))
 568
 569 (with-test (:name :write/write-to-string-compiler-macro-lp/598374+581564)
 570   (let ((test (checked-compile
 571                `(lambda (object &optional output-stream)
 572                   (write object :stream output-stream)))))
 573     (assert (equal "(HELLO WORLD)"
 574                    (with-output-to-string (*standard-output*)
 575                      (let ((list '(hello world)))
 576                        (assert (eq list (funcall test list)))))))
 577     (assert (equal "12"
 578                    (with-output-to-string (*standard-output*)
 579                      (assert (eql 12 (funcall test 12)))))))
 580   (let ((test (checked-compile
 581                `(lambda ()
 582                   (let ((*print-length* 42))
 583                     (write-to-string *print-length* :length nil))))))
 584     (assert (equal "42" (funcall test)))))
 585
 586 (with-test (:name (format :compile-literal-dest-string))
 587   (multiple-value-bind (fun failure-p warnings)
 588       (checked-compile `(lambda (x) (format "~A" x))
 589                        :allow-warnings t)
 590     (declare (ignore fun))
 591     (assert failure-p)
 592     (assert (= (length warnings) 1))))
 593
 594 (with-test (:name :bug-308961)
 595   (assert (string= (format nil "~4,1F" 0.001) " 0.0"))
 596   (assert (string= (format nil "~4,1@F" 0.001) "+0.0"))
 597   (assert (string= (format nil "~E" 0.01) "1.e-2"))
 598   (assert (string= (format nil "~G" 0.01) "1.00e-2")))
 599
 600 (with-test (:name (:fp-print-read-consistency single-float))
 601   (let ((*random-state* (make-random-state t))
 602         (oops))
 603     (loop for f = most-positive-single-float then (/ f 2.0)
 604           while (> f 0.0)
 605           do (loop repeat 10
 606                    for fr = (random f)
 607                    do (unless (eql fr (read-from-string (prin1-to-string fr)))
 608                         (push fr oops)
 609                         (return))))
 610     (loop for f = most-negative-single-float then (/ f 2.0)
 611           while (< f -0.0)
 612           do (loop repeat 10
 613                    for fr = (- (random (- f)))
 614                    do (unless (eql fr (read-from-string (prin1-to-string fr)))
 615                         (push fr oops)
 616                         (return))))
 617     (when oops
 618       (error "FP print-read inconsistencies:~%~:{  ~S => ~S~%~}"
 619              (mapcar (lambda (f)
 620                        (list f (read-from-string (prin1-to-string f))))
 621                      oops)))))
 622
 623 (with-test (:name (:fp-print-read-consistency double-float))
 624   (let ((*random-state* (make-random-state t))
 625         (oops))
 626     ;; FIXME skipping denormalized floats due to bug 793774.
 627     (loop for f = most-positive-double-float then (/ f 2d0)
 628           while (> f 0d0)
 629           do (loop repeat 10
 630                    for fr = (random f)
 631                    do (unless (float-denormalized-p fr)
 632                         (unless (eql fr (read-from-string (prin1-to-string fr)))
 633                           (push fr oops)
 634                           (return)))))
 635     (loop for f = most-negative-double-float then (/ f 2d0)
 636           while (< f -0d0)
 637           do (loop repeat 10
 638                    for fr = (- (random (- f)))
 639                    do (unless (float-denormalized-p fr)
 640                         (unless (eql fr (read-from-string (prin1-to-string fr)))
 641                           (push fr oops)
 642                           (return)))))
 643     (when oops
 644       (error "FP print-read inconsistencies:~%~:{  ~S => ~S~%~}"
 645              (mapcar (lambda (f)
 646                        (list f (read-from-string (prin1-to-string f))))
 647                      oops)))))
 648
 649 (with-test (:name :bug-811386)
 650   (assert (equal "   0.00" (format nil "~7,2,-2f" 0)))
 651   (assert (equal "   0.00" (format nil "~7,2,2f" 0)))
 652   (assert (equal "   0.01" (format nil "~7,2,-2f" 1)))
 653   (assert (equal " 100.00" (format nil "~7,2,2f" 1)))
 654   (assert (equal "   0.00" (format nil "~7,2,-2f" 0.1)))
 655   (assert (equal "  10.00" (format nil "~7,2,2f" 0.1)))
 656   (assert (equal "   0.01" (format nil "~7,2,-2f" 0.5))))
 657
 658 (with-test (:name :bug-867684)
 659   (assert (equal "ab" (format nil "a~0&b"))))
 660
 661 (with-test (:name :print-unreadably-function)
 662   (assert (equal "\"foo\""
 663                  (handler-bind ((print-not-readable #'sb-ext:print-unreadably))
 664                    (write-to-string (coerce "foo" 'base-string) :readably t)))))
 665
 666 (with-test (:name :printing-specialized-arrays-readably)
 667   (let ((*read-eval* t)
 668         (dimss (loop repeat 10
 669                      collect (loop repeat (1+ (random 3))
 670                                    collect (1+ (random 10)))))
 671         (props sb-vm::*specialized-array-element-type-properties*))
 672     (labels ((random-elt (type)
 673                (case type
 674                  (base-char
 675                   (code-char (random 128)))
 676                  (character
 677                   (code-char (random char-code-limit)))
 678                  (single-float
 679                   (+ least-positive-normalized-single-float
 680                      (random most-positive-single-float)))
 681                  (double-float
 682                   (+ least-positive-normalized-double-float
 683                          (random most-positive-double-float)))
 684                  (bit
 685                   (random 2))
 686                  (fixnum
 687                   (random most-positive-fixnum))
 688                  ((t)
 689                   t)
 690                  (otherwise
 691                   (destructuring-bind (type x) type
 692                     (ecase type
 693                       (unsigned-byte
 694                        (random (1- (expt 2 x))))
 695                       (signed-byte
 696                        (- (random (expt 2 (1- x)))))
 697                       (complex
 698                        (complex (random-elt x) (random-elt x)))))))))
 699       (dotimes (i (length props))
 700         (let ((et (sb-vm::saetp-specifier (aref props i))))
 701           (when et
 702             (when (eq 'base-char et)
 703               ;; base-strings not included in the #. printing.
 704               (go :next))
 705             (dolist (dims dimss)
 706               (let ((a (make-array dims :element-type et)))
 707                 (assert (equal et (array-element-type a)))
 708                 (dotimes (i (array-total-size a))
 709                   (setf (row-major-aref a i) (random-elt et)))
 710                 (let ((copy (read-from-string (write-to-string a :readably t))))
 711                   (assert (equal dims (array-dimensions copy)))
 712                   (assert (equal et (array-element-type copy)))
 713                   (assert (equal (array-total-size a) (array-total-size copy)))
 714                   (dotimes (i (array-total-size a))
 715                     (assert (equal (row-major-aref a i) (row-major-aref copy i)))))))))
 716         :next))))
 717
 718 (with-test (:name (format :negative-colinc-and-mincol))
 719   (assert-error (format nil "~-2a" 1))
 720   (assert-error (format nil "~,0a" 1)))
 721
 722 (with-test (:name (format :bug-905817))
 723   ;; The bug manifests itself in an endless loop in FORMAT.
 724   ;; Correct behaviour is to signal an error.
 725   (handler-case
 726       (with-timeout 5
 727         (assert-error (format nil "e~8,0s" 12395)))
 728     (timeout ()
 729       (error "Endless loop in FORMAT"))))
 730
 731 (with-test (:name :format-type-check)
 732   (assert (equal "1/10" (format nil "~2r" 1/2)))
 733   (assert-error (format nil "~r" 1.32) sb-format:format-error)
 734   (assert-error (format nil "~c" 1.32) sb-format:format-error)
 735   (assert (equal "1/10" (eval '(format nil "~2r" 1/2))))
 736   (assert-error (eval '(format nil "~r" 1.32)) sb-format:format-error)
 737   (assert-error (eval '(format nil "~c" 1.32)) sb-format:format-error))
 738
 739 ;; Setup for test of print-object on a class with no proper name.
 740 ;; There are various PRINT-OBJECT tests strewn throughout, all of which
 741 ;; are not in the obvious place to me, except for perhaps 'clos.impure'
 742 ;; which is also not the right place because that file concerns CLOS
 743 ;; behavior in general, not to mention being far too noisy in its output.
 744 (defclass fruit () (a))
 745 (defvar *fruit1* (find-class 'fruit))
 746 (setf (find-class 'fruit) nil)
 747 (defclass fruit () (n o))
 748 (defvar *fruit2* (find-class 'fruit))
 749 (setf (find-class 'fruit) nil)
 750 (defclass fruit () (x))
 751 (with-test (:name (print-object :improper-class-name))
 752   (assert (string/= (write-to-string *fruit1*) (write-to-string *fruit2*)))
 753   (assert (string/= (write-to-string (find-class 'fruit))
 754                     (write-to-string *fruit1*))))
 755
 756 (with-test (:name :format-readably)
 757   (let ((*print-readably* t))
 758     (assert (format nil "~$" #'format))
 759     (assert (format nil "~d" #'format))
 760     (assert (format nil "~x" #'format))
 761     (assert (format nil "~b" #'format))
 762     (assert (format nil "~3r" #'format))
 763     (locally
 764         (declare (notinline format))
 765       (assert (format nil "~$" #'format))
 766       (assert (format nil "~d" #'format))
 767       (assert (format nil "~x" #'format))
 768       (assert (format nil "~b" #'format))
 769       (assert (format nil "~3r" #'format)))))
 770
 771 (with-test (:name (format *print-base*))
 772   (let ((*print-base* 3))
 773     (assert (equal (format nil "~g" '(123)) "(123)"))
 774     (assert (equal (format nil "~f" '(123)) "(123)"))
 775     (assert (equal (format nil "~e" '(123)) "(123)"))
 776     (assert (equal (format nil "~$" '(123)) "(123)"))
 777     (locally
 778         (declare (notinline format))
 779       (assert (equal (format nil "~g" '(123)) "(123)"))
 780       (assert (equal (format nil "~f" '(123)) "(123)"))
 781       (assert (equal (format nil "~e" '(123)) "(123)"))
 782       (assert (equal (format nil "~$" '(123)) "(123)")))))
 783
 784 (with-test (:name (format :concatenate))
 785   (assert (equal
 786            (funcall (checked-compile `(lambda (x) (format nil "~s" (the string x))))
 787                     "\\")
 788            (prin1-to-string "\\"))))
 789
 790 (with-test (:name (write :stream nil))
 791   (assert
 792    (equal
 793     (with-output-to-string (*standard-output*)
 794       (funcall (checked-compile `(lambda () (write "xx" :stream nil)))))
 795     "\"xx\"")))
 796
 797 (define-condition foo () (a))
 798 (defvar *ccc* (make-condition 'foo))
 799 (define-condition foo (warning) (a))
 800 (with-test (:name :write-obsolete-condition)
 801   (assert (search "UNPRINTABLE" (write-to-string *ccc*))))
 802
 803 (with-test (:name (format :no-overeager-compile-time-processing))
 804   (checked-compile '(lambda (x) (format t "~/nopackage:nofun/" x))))