File: print.impure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (419 lines) | stat: -rw-r--r-- 18,314 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
;;;; miscellaneous tests of printing stuff

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(load "assertoid.lisp")
(use-package "ASSERTOID")

;;; We should be able to output X readably (at least when *READ-EVAL*).
(defun assert-readable-output (x)
  (assert (eql x
               (let ((*read-eval* t))
                 (read-from-string (with-output-to-string (s)
                                     (write x :stream s :readably t)))))))

;;; Even when *READ-EVAL* is NIL, we should be able to output some
;;; (not necessarily readable) representation without signalling an
;;; error.
(defun assert-unreadable-output (x)
  (let ((*read-eval* nil))
    (with-output-to-string (s) (write x :stream s :readably nil))))

(defun assert-output (x)
  (assert-readable-output x)
  (assert-unreadable-output x))

;;; Nathan Froyd reported that sbcl-0.6.11.34 screwed up output of
;;; floating point infinities.
(dolist (x (list short-float-positive-infinity short-float-negative-infinity
                 single-float-positive-infinity single-float-negative-infinity
                 double-float-positive-infinity double-float-negative-infinity
                 long-float-positive-infinity long-float-negative-infinity))
  (assert-output x))

;;; Eric Marsden reported that this would blow up in CMU CL (even
;;; though ANSI says that the mismatch between ~F expected type and
;;; provided string type is supposed to be handled without signalling
;;; an error) and provided a fix which was ported to sbcl-0.6.12.35.
(assert (null (format t "~F" "foo")))

;;; This was a bug in SBCL until 0.6.12.40 (originally reported as a
;;; CMU CL bug by Erik Naggum on comp.lang.lisp).
(loop for base from 2 to 36
      with *print-radix* = t
      do (let ((*print-base* base))
           (assert (string= "#*101" (format nil "~S" #*101)))))

;;; bug in sbcl-0.7.1.25, reported by DB sbcl-devel 2002-02-25
(assert (string= "0.5" (format nil "~2D" 0.5)))

;;; we want malformed format strings to cause errors rather than have
;;; some DWIM "functionality".
(assert (raises-error? (format nil "~:2T")))

;;; bug reported, with fix, by Robert Strandh, sbcl-devel 2002-03-09,
;;; fixed in sbcl-0.7.1.36:
(assert (string= (format nil "~2,3,8,'0$" 1234567.3d0) "1234567.30"))

;;; checks that other FORMAT-DOLLAR output remains sane after the
;;; 0.7.1.36 change
(assert (string= (format nil "~$" 0) "0.00"))
(assert (string= (format nil "~$" 4) "4.00"))
(assert (string= (format nil "~$" -4.0) "-4.00"))
(assert (string= (format nil "~2,7,11$" -4.0) "-0000004.00"))
(assert (string= (format nil "~2,7,11,' $" 1.1) " 0000001.10"))
(assert (string= (format nil "~1,7,11,' $" 1.1) "  0000001.1"))
(assert (string= (format nil "~1,3,8,' $" 7.3) "   007.3"))
(assert (string= (format nil "~2,3,8,'0$" 7.3) "00007.30"))

;;; Check for symbol lookup in ~/ / directive -- double-colon was
;;; broken in 0.7.1.36 and earlier
(defun print-foo (stream arg colonp atsignp &rest params)
  (declare (ignore colonp atsignp params))
  (format stream "~d" arg))

(assert (string= (format nil "~/print-foo/" 2) "2"))
(assert (string= (format nil "~/cl-user:print-foo/" 2) "2"))
(assert (string= (format nil "~/cl-user::print-foo/" 2) "2"))
(assert (raises-error? (format nil "~/cl-user:::print-foo/" 2)))
(assert (raises-error? (format nil "~/cl-user:a:print-foo/" 2)))
(assert (raises-error? (format nil "~/a:cl-user:print-foo/" 2)))
(assert (raises-error? (format nil "~/cl-user:print-foo:print-foo/" 2)))

;;; better make sure that we get this one right, too
(defun print-foo\:print-foo (stream arg colonp atsignp &rest params)
  (declare (ignore colonp atsignp params))
  (format stream "~d" arg))

(assert (string= (format nil "~/cl-user:print-foo:print-foo/" 2) "2"))
(assert (string= (format nil "~/cl-user::print-foo:print-foo/" 2) "2"))

;;; Check for error detection of illegal directives in a~<..~> justify
;;; block (see ANSI section 22.3.5.2)
(assert (raises-error? (format nil "~<~W~>" 'foo)))
(assert (raises-error? (format nil "~<~<~A~:>~>" '(foo))))
(assert (string= (format nil "~<~<~A~>~>" 'foo) "FOO"))

;;; Check that arrays that we print while *PRINT-READABLY* is true are
;;; in fact generating similar objects.
(assert (equal (array-dimensions
                (read-from-string
                 (with-output-to-string (s)
                   (let ((*print-readably* t))
                     (print (make-array '(1 2 0)) s)))))
               '(1 2 0)))

(dolist (array (list (make-array '(1 0 1))
                     (make-array 0 :element-type nil)
                     (make-array 1 :element-type 'base-char)
                     (make-array 1 :element-type 'character)))
  (assert (multiple-value-bind (result error)
              (ignore-errors (read-from-string
                              (with-output-to-string (s)
                                (let ((*print-readably* t))
                                  (print array s)))))
            ;; it might not be readably-printable
            (or (typep error 'print-not-readable)
                (and
                 ;; or else it had better have the same dimensions
                 (equal (array-dimensions result) (array-dimensions array))
                 ;; and the same element-type
                 (equal (array-element-type result) (array-element-type array)))))))

;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE
(write #(1 2 3) :pretty nil :readably t)

;;; another UNBOUND-VARIABLE, this time due to a bug in FORMATTER
;;; expanders.
(funcall (formatter "~@<~A~:*~A~:>") nil 3)

;;; the PPC floating point backend was at one point sufficiently
;;; broken that this looped infinitely or caused segmentation
;;; violations through stack corruption.
(print 0.0001)

;;; In sbcl-0.8.7, the ~W format directive interpreter implemented the
;;; sense of the colon and at-sign modifiers exactly backwards.
;;;
;;; (Yes, the test for this *is* substantially hairier than the fix;
;;; wanna make something of it?)
(cl:in-package :cl-user)
(defstruct wexerciser-0-8-7)
(defun wexercise-0-8-7-interpreted (wformat)
  (format t wformat (make-wexerciser-0-8-7)))
(defmacro define-compiled-wexercise-0-8-7 (wexercise wformat)
  `(defun ,wexercise ()
    (declare (optimize (speed 3) (space 1)))
    (format t ,wformat (make-wexerciser-0-8-7))
    (values)))
(define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-without-atsign "~W")
(define-compiled-wexercise-0-8-7 wexercise-0-8-7-compiled-with-atsign "~@W")
(defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
  (unless (and *print-level* *print-length*)
    (error "gotcha coming")))
(let ((*print-level* 11)
      (*print-length* 12))
  (wexercise-0-8-7-interpreted "~W")
  (wexercise-0-8-7-compiled-without-atsign))
(remove-method #'print-object
               (find-method #'print-object
                            '(:before)
                            (mapcar #'find-class '(wexerciser-0-8-7 t))))
(defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream)
  (when (or *print-level* *print-length*)
    (error "gotcha going")))
(let ((*print-level* 11)
      (*print-length* 12))
  (wexercise-0-8-7-interpreted "~@W")
  (wexercise-0-8-7-compiled-with-atsign))

;;; WRITE-TO-STRING was erroneously DEFKNOWNed as FOLDABLE
;;;
;;; This bug from PFD
(defpackage "SCRATCH-WRITE-TO-STRING" (:use))
(with-standard-io-syntax
  (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING"))
         (answer (write-to-string 'scratch-write-to-string::x :readably nil)))
    (assert (string= answer "X"))))
;;; and a couple from Bruno Haible
(defun my-pprint-reverse (out list)
  (write-char #\( out)
  (when (setq list (reverse list))
    (loop
     (write (pop list) :stream out)
     (when (endp list) (return))
     (write-char #\Space out)))
  (write-char #\) out))
(with-standard-io-syntax
  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
    (set-pprint-dispatch '(cons (member foo)) 'my-pprint-reverse 0)
    (let ((answer (write-to-string '(foo bar :boo 1) :pretty t :escape t)))
      (assert (string= answer "(1 :BOO BAR FOO)")))))
(defun my-pprint-logical (out list)
  (pprint-logical-block (out list :prefix "(" :suffix ")")
    (when list
      (loop
       (write-char #\? out)
       (write (pprint-pop) :stream out)
       (write-char #\? out)
       (pprint-exit-if-list-exhausted)
       (write-char #\Space out)))))
(with-standard-io-syntax
  (let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
    (set-pprint-dispatch '(cons (member bar)) 'my-pprint-logical 0)
    (let ((answer (write-to-string '(bar foo :boo 1) :pretty t :escape t)))
      (assert (string= answer "(?BAR? ?FOO? ?:BOO? ?1?)")))))

;;; FORMAT string compile-time checker failure, reported by Thomas
;;; F. Burdick
(multiple-value-bind (f w-p f-p)
    (compile nil '(lambda () (format nil "~{")))
  (assert (and w-p f-p))
  (assert (nth-value 1 (ignore-errors (funcall f)))))

;;; floating point print/read consistency
(let ((x (/ -9.349640046247849d-21 -9.381494249123696d-11)))
  (let ((y (read-from-string (write-to-string x :readably t))))
    (assert (eql x y))))

(let ((x1 (float -5496527/100000000000000000))
      (x2 (float -54965272/1000000000000000000)))
  (assert (or (equal (multiple-value-list (integer-decode-float x1))
                     (multiple-value-list (integer-decode-float x2)))
              (string/= (prin1-to-string x1) (prin1-to-string x2)))))

;;; readable printing of arrays with *print-radix* t
(let ((*print-radix* t)
      (*print-readably* t)
      (*print-pretty* nil))
  (let ((output (with-output-to-string (s)
                  (write #2a((t t) (nil nil)) :stream s))))
    (assert (equalp (read-from-string output) #2a((t t) (nil nil))))))

;;; NIL parameters to "interpreted" FORMAT directives
(assert (string= (format nil "~v%" nil) (string #\Newline)))

;;; PRINC-TO-STRING should bind print-readably
(let ((*print-readably* t))
  (assert (string= (princ-to-string #\7)
                   (write-to-string #\7 :escape nil :readably nil))))

;;; in FORMAT, ~^ inside ~:{ should go to the next case, not break
;;; iteration, even if one argument is just a one-element list.
(assert (string= (format nil "~:{~A~^~}" '((A) (C D))) "AC"))

;;; errors should be raised if pprint and justification are mixed
;;; injudiciously...
(dolist (x (list "~<~:;~>~_" "~<~:;~>~I" "~<~:;~>~W"
                 "~<~:;~>~:T" "~<~:;~>~<~:>" "~_~<~:;~>"
                 "~I~<~:;~>" "~W~<~:;~>" "~:T~<~:;~>" "~<~:>~<~:;~>"))
  (assert (raises-error? (format nil x nil)))
  (assert (raises-error? (format nil (eval `(formatter ,x)) nil))))
;;; ...but not in judicious cases.
(dolist (x (list "~<~;~>~_" "~<~;~>~I" "~<~;~>~W"
                 "~<~;~>~:T" "~<~;~>~<~>" "~_~<~;~>"
                 "~I~<~;~>" "~W~<~;~>" "~:T~<~;~>" "~<~>~<~;~>"
                 "~<~:;~>~T" "~T~<~:;~>"))
  (assert (format nil x nil))
  (assert (format nil (eval `(formatter ,x)) nil)))

;;; bug 350: bignum printing so memory-hungry that heap runs out
;;; -- just don't stall here forever on a slow box
(handler-case
    (with-timeout 10
      (print (ash 1 1000000)))
  (timeout ()
    (print 'timeout!)))

;;; bug 371: bignum print/read inconsistency
(defvar *bug-371* -7043009959286724629649270926654940933664689003233793014518979272497911394287216967075767325693021717277238746020477538876750544587281879084559996466844417586093291189295867052594478662802691926547232838591510540917276694295393715934079679531035912244103731582711556740654671309980075069010778644542022/670550434139267031632063192770201289106737062379324644110801846820471752716238484923370056920388400273070254958650831435834503195629325418985020030706879602898158806736813101434594805676212779217311897830937606064579213895527844045511878668289820732425014254579493444623868748969110751636786165152601)
(let ((*print-base* 5)
      (*read-base* 5)
      (*print-radix* nil))
  (assert (= *bug-371* (read-from-string (prin1-to-string *bug-371*)))))

;;; a spot of random-testing for rational printing
(defvar *seed-state* (make-random-state))
(print *seed-state*) ; so that we can reproduce errors
(let ((seed (make-random-state *seed-state*)))
  (loop repeat 42
     do (let ((n (random (ash 1 1000) seed))
              (d (random (ash 1 1000) seed)))
          (when (zerop (random 2 seed))
            (setf n (- n)))
          (let ((r (/ n d)))
            (loop for base from 2 to 36
               do (let ((*print-base* base)
                        (*read-base* base)
                        (*print-radix* nil))
                    (assert (= r (read-from-string (prin1-to-string r))))
                    (if (= 36 base)
                        (decf *read-base*)
                        (incf *read-base*))
                    (assert (not (eql r (read-from-string (prin1-to-string r)))))
                    (let ((*print-radix* t))
                      (assert (= r (read-from-string
                                    (princ-to-string r)))))))))
       (write-char #\.)
       (finish-output)))

;;;; Bugs, found by PFD
;;; NIL parameter for ~^ means `not supplied'
(loop for (format arg result) in
      '(("~:{~D~v^~D~}" ((3 1 4) (1 0 2) (7 nil) (5 nil 6)) "341756")
        ("~:{~1,2,v^~A~}" ((nil 0) (3 1) (0 2)) "02"))
      do (assert (string= (funcall #'format nil format arg) result))
      do (assert (string= (with-output-to-string (s)
                            (funcall (eval `(formatter ,format)) s arg))
                          result)))

;;; NIL first parameter for ~R is equivalent to no parameter.
(assert (string= (format nil "~VR" nil 5) "five"))
(assert (string= (format nil (formatter "~VR") nil 6) "six"))

;;; CSR inserted a bug into Burger & Dybvig's float printer.  Caught
;;; by Raymond Toy
(assert (string= (format nil "~E" 1d23) "1.d+23"))

;;; Fixed-format bugs from CLISP's test suite (reported by Bruno
;;; Haible, bug 317)
(assert (string= (format nil "~1F" 10) "10."))
(assert (string= (format nil "~0F" 10) "10."))
(assert (string= (format nil "~2F" 1234567.1) "1234567."))

;;; here's one that seems to fail most places.  I think this is right,
;;; and most of the other answers I've seen are definitely wrong.
(assert (string= (format nil "~G" 1d23) "100000000000000000000000.    "))

;;; Adam Warner's test case
(assert (string= (format nil "~@F" 1.23) "+1.23"))


;;; New (2005-11-08, also known as CSR House day) float format test
;;; cases.  Simon Alexander, Raymond Toy, and others
(assert (string= (format nil "~9,4,,-7E" pi) ".00000003d+8"))
(assert (string= (format nil "~9,4,,-5E" pi) ".000003d+6"))
(assert (string= (format nil "~5,4,,7E" pi) "3141600.d-6"))
(assert (string= (format nil "~11,4,,3E" pi) "  314.16d-2"))
(assert (string= (format nil "~11,4,,5E" pi) "  31416.d-4"))
(assert (string= (format nil "~11,4,,0E" pi) "  0.3142d+1"))
(assert (string= (format nil "~9,,,-1E" pi) ".03142d+2"))
(assert (string= (format nil "~,,,-2E" pi) "0.003141592653589793d+3"))
(assert (string= (format nil "~,,,2E" pi) "31.41592653589793d-1"))
(assert (string= (format nil "~E" pi) "3.141592653589793d+0"))
(assert (string= (format nil "~9,5,,-1E" pi) ".03142d+2"))
(assert (string= (format nil "~11,5,,-1E" pi) " 0.03142d+2"))
(assert (string= (format nil "~G" pi) "3.141592653589793    "))
(assert (string= (format nil "~9,5G" pi) "3.1416    "))
(assert (string= (format nil "|~13,6,2,7E|" pi) "| 3141593.d-06|"))
(assert (string= (format nil "~9,3,2,0,'%E" pi) "0.314d+01"))
(assert (string= (format nil "~9,0,6f" pi) " 3141593."))
(assert (string= (format nil "~6,2,1,'*F" pi) " 31.42"))
(assert (string= (format nil "~6,2,1,'*F" (* 100 pi)) "******"))
(assert (string= (format nil "~9,3,2,-2,'%@E" pi) "+.003d+03"))
(assert (string= (format nil "~10,3,2,-2,'%@E" pi) "+0.003d+03"))
(assert (string= (format nil "~15,3,2,-2,'%,'=@E" pi) "=====+0.003d+03"))
(assert (string= (format nil "~9,3,2,-2,'%E" pi) "0.003d+03"))
(assert (string= (format nil "~8,3,2,-2,'%@E" pi) "%%%%%%%%"))

(assert (string= (format nil "~g" 1e0) "1.    "))
(assert (string= (format nil "~g" 1.2d40) "12000000000000000000000000000000000000000.    "))

(assert (string= (format nil "~e" 0) "0.0e+0"))
(assert (string= (format nil "~e" 0d0) "0.0d+0"))
(assert (string= (format nil "~9,,4e" 0d0) "0.0d+0000"))

(let ((table (make-hash-table)))
  (setf (gethash 1 table) t)
  (assert
   (raises-error? (with-standard-io-syntax
                    (let ((*read-eval* nil)
                          (*print-readably* t))
                      (with-output-to-string (*standard-output*)
                        (prin1 table))))
                  print-not-readable)))

;; Test that we can print characters readably regardless of the external format
;; of the stream.

(defun test-readable-character (character external-format)
  (let ((file "print.impure.tmp"))
    (unwind-protect
         (progn
           (with-open-file (stream file
                                   :direction :output
                                   :external-format external-format
                                   :if-exists :supersede)
             (write character :stream stream :readably t))
           (with-open-file (stream file
                                   :direction :input
                                   :external-format external-format
                                   :if-does-not-exist :error)
             (assert (char= (read stream) character))))
      (ignore-errors
        (delete-file file)))))

#+sb-unicode
(with-test (:name (:print-readable :character :utf-8))
  (test-readable-character (code-char #xfffe) :utf-8))

#+sb-unicode
(with-test (:name (:print-readable :character :iso-8859-1))
  (test-readable-character (code-char #xfffe) :iso-8859-1))

(assert (string= (eval '(format nil "~:C" #\a)) "a"))
(assert (string= (format nil (formatter "~:C") #\a) "a"))

;;; This used to trigger an AVER instead.
(assert (raises-error? (format t "~>") sb-format:format-error))

;;; success