0.8.12.15:
[sbcl.git] / 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)