1 ;;;; tests related to Lisp streams
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "assertoid.lisp")
15 (use-package "ASSERTOID")
17 ;;; type errors for inappropriate stream arguments, fixed in
20 (declare (optimize (safety 3)))
21 (assert (raises-error?
(make-two-way-stream (make-string-output-stream)
22 (make-string-output-stream))
24 (assert (raises-error?
(make-two-way-stream (make-string-input-stream "foo")
25 (make-string-input-stream "bar"))
27 ;; the following two aren't actually guaranteed, because ANSI, as it
28 ;; happens, doesn't say "should signal an error" for
29 ;; MAKE-ECHO-STREAM. It's still good to have, but if future
30 ;; maintenance work causes this test to fail because of these
31 ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses
32 ;; from the test. -- CSR, 2002-10-06
33 (assert (raises-error?
(make-echo-stream (make-string-output-stream)
34 (make-string-output-stream))
36 (assert (raises-error?
(make-echo-stream (make-string-input-stream "foo")
37 (make-string-input-stream "bar"))
39 (assert (raises-error?
(make-concatenated-stream
40 (make-string-output-stream)
41 (make-string-input-stream "foo"))
44 ;;; bug 225: STRING-STREAM was not a class
45 (eval `(defgeneric bug225
(s)
46 ,@(mapcar (lambda (class)
47 `(:method
:around
((s ,class
)) (cons ',class
(call-next-method))))
48 '(stream string-stream sb-impl
::string-input-stream
49 sb-impl
::string-output-stream
))
50 (:method
(class) nil
)))
52 (assert (equal (bug225 (make-string-input-stream "hello"))
53 '(sb-impl::string-input-stream string-stream stream
)))
54 (assert (equal (bug225 (make-string-output-stream))
55 '(sb-impl::string-output-stream string-stream stream
)))
58 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
59 (let ((p "signed-byte-8-test.data"))
62 :element-type
'(unsigned-byte 8)
63 :if-exists
:supersede
)
65 (with-open-file (s p
:element-type
'(signed-byte 8))
66 (assert (= (read-byte s
) -
1)))
69 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
71 (let* ((p "this-file-will-exist")
72 (stream (close (open p
:direction
:output
:if-exists
:error
))))
76 (null (with-open-file (s p
:direction
:output
:if-exists nil
) s
)))
79 (with-open-file (s p
:direction
:output
:if-exists
:error
)))))
82 (assert (raises-error?
(read-byte (make-string-input-stream "abc"))
84 (assert (raises-error?
(with-open-file (s "/dev/zero")
87 ;;; bidirectional streams getting confused about their position
88 (let ((p "bidirectional-stream-test"))
89 (with-open-file (s p
:direction
:output
:if-exists
:supersede
)
90 (with-standard-io-syntax
91 (format s
"~S ~S ~S~%" 'these
'are
'symbols
)))
92 (with-open-file (s p
:direction
:io
:if-exists
:overwrite
)
94 (with-standard-io-syntax
97 (let ((line (read-line s
))
98 (want "THESE INSERTMBOLS"))
99 (unless (equal line want
)
100 (error "wanted ~S, got ~S" want line
))))
103 ;;; :DIRECTION :IO didn't work on non-existent pathnames
104 (let ((p "direction-io-test"))
105 (ignore-errors (delete-file p
))
106 (with-open-file (s p
:direction
:io
)
109 (file-position s
:start
)
110 (assert (char= (read-char s
) #\
1)))
113 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
114 (assert (= 0 (file-position (make-broadcast-stream))))
115 (assert (file-position (make-broadcast-stream) :start
))
116 (assert (file-position (make-broadcast-stream) 0))
117 (assert (not (file-position (make-broadcast-stream) 1)))
118 (let ((s (make-broadcast-stream)))
120 (assert (not (file-position s
1)))
121 (assert (= 0 (file-position s
))))
123 (let ((p "broadcast-stream-test"))
124 (ignore-errors (delete-file p
))
125 (with-open-file (f p
:direction
:output
)
126 (let ((s (make-broadcast-stream f
)))
127 (assert (= 0 (file-position s
)))
128 (assert (file-position s
:start
))
129 (assert (file-position s
0))
131 (assert (= 1 (file-position s
))) ; unicode...
132 (assert (file-position s
0))))
135 ;;; CLOSING a non-new streams should not delete them, and superseded
136 ;;; files should be restored.
137 (let ((test "test-file-for-close-should-not-delete"))
138 (macrolet ((test-mode (mode)
140 (catch :close-test-exit
141 (with-open-file (f test
:direction
:output
:if-exists
,mode
)
142 (write-line "test" f
)
143 (throw :close-test-exit t
)))
144 (assert (and (probe-file test
) ,mode
)))))
147 (with-open-file (f test
:direction
:output
)
148 (write-line "test" f
))
150 (test-mode :overwrite
)
151 ;; FIXME: We really should recover supersede files as well, according to
152 ;; CLOSE in CLHS, but at the moment we don't.
153 ;; (test-mode :supersede)
155 (test-mode :rename-and-delete
))
156 (when (probe-file test
)
157 (delete-file test
)))))
159 ;;; test for read-write invariance of signed bytes, from Bruno Haible
160 ;;; cmucl-imp 2004-09-06
161 (defun bin-stream-test (&key
(size (integer-length most-positive-fixnum
))
162 (type 'unsigned-byte
) (file-name "stream-impure.tmp")
164 (bytes (if (eq type
'signed-byte
)
165 (loop :repeat num-bytes
:collect
166 (- (random (ash 1 size
))
168 (loop :repeat num-bytes
:collect
169 (random (ash 1 size
))))))
170 (with-open-file (foo file-name
:direction
:output
:if-exists
:supersede
171 :element-type
(list type size
))
173 (write-byte byte foo
)))
175 (with-open-file (foo file-name
:direction
:input
176 :element-type
(list type size
))
177 (list (stream-element-type foo
) (file-length foo
) bytes
178 (loop :for byte
:in bytes
:for nb
= (read-byte foo
) :collect nb
179 :unless
(= nb byte
) :do
180 (flet ((by-out (sz by
)
181 (format nil
"~v,'0,' ,4:b"
182 (+ sz
(floor sz
4)) by
)))
183 (error "~& * [(~s ~s)] ~a != ~a~%" type size
184 (by-out size byte
) (by-out size nb
))))))
185 (delete-file file-name
)))
186 (loop for size from
2 to
40 do
(bin-stream-test :size size
:type
'signed-byte
))
188 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
189 ;;; contain a stream element.
191 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
192 ;;; or slow paths are being taken for each element type. To check the
193 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
196 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
198 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
199 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
201 (let ((pathname "read-sequence.data"))
203 ;; Create the binary data.
204 (with-open-file (stream pathname
206 :if-exists
:supersede
207 :element-type
'(unsigned-byte 8))
208 (write-byte 255 stream
))
210 ;; Check the slow path for generic vectors.
211 (let ((sequence (make-array 1)))
212 (with-open-file (stream pathname
214 :element-type
'(unsigned-byte 8))
215 (read-sequence sequence stream
)
216 (assert (equalp sequence
#(255)))))
218 (let ((sequence (make-array 1)))
219 (with-open-file (stream pathname
221 :external-format
:latin-1
222 :element-type
'character
)
223 (read-sequence sequence stream
)
224 (assert (equalp sequence
#(#.
(code-char 255))))))
226 ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
228 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
229 (with-open-file (stream pathname
231 :element-type
'(unsigned-byte 8))
232 (read-sequence sequence stream
)
233 (assert (equalp sequence
#(255)))))
235 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
236 (with-open-file (stream pathname
238 :element-type
'(signed-byte 8))
239 (read-sequence sequence stream
)
240 (assert (equalp sequence
#(-1)))))
242 ;; A bivalent stream can be read to a unsigned-byte vector, a
243 ;; string, or a generic vector
245 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
246 (with-open-file (stream pathname
248 :element-type
:default
)
249 (read-sequence sequence stream
)
250 (assert (equalp sequence
#(255)))))
252 (let ((sequence (make-array 1 :element-type
'character
)))
253 (with-open-file (stream pathname
255 :external-format
:latin-1
256 :element-type
:default
)
257 (read-sequence sequence stream
)
258 (assert (equalp sequence
#(#.
(code-char 255))))))
260 (let ((sequence (make-array 1)))
261 (with-open-file (stream pathname
263 :external-format
:latin-1
264 :element-type
:default
)
265 (read-sequence sequence stream
)
266 (assert (equalp sequence
#(#.
(code-char 255))))))
268 ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
271 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
272 (with-open-file (stream pathname
274 :element-type
'(unsigned-byte 8))
276 (read-sequence sequence stream
)
277 (error "READ-SEQUENCE didn't signal an error"))
278 (type-error (condition)
279 (assert (= (type-error-datum condition
) 255))
280 (assert (subtypep (type-error-expected-type condition
)
281 '(signed-byte 8)))))))
283 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
284 (with-open-file (stream pathname
286 :element-type
'(signed-byte 8))
288 (read-sequence sequence stream
)
289 (error "READ-SEQUENCE didn't signal an error"))
290 (type-error (condition)
291 (assert (= (type-error-datum condition
) -
1))
292 (assert (subtypep (type-error-expected-type condition
)
293 '(unsigned-byte 8)))))))
295 ;; Can't read a signed-byte from a bivalent stream
297 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
298 (with-open-file (stream pathname
300 :external-format
:latin1
301 :element-type
:default
)
303 (read-sequence sequence stream
)
304 (error "READ-SEQUENCE didn't signal an error"))
305 (type-error (condition)
306 (assert (eql (type-error-datum condition
) (code-char 255)))
307 (assert (subtypep (type-error-expected-type condition
)
308 '(signed-byte 8)))))))
309 (delete-file pathname
))
311 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
312 ;;; write a sequence element.
314 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
315 ;;; or slow paths are being taken for each element type. See the
316 ;;; READ-SEQUENCE tests above for more information.
318 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
320 (let ((pathname "write-sequence.data")
321 (generic-sequence (make-array 1 :initial-contents
'(255)))
322 (generic-character-sequence (make-array 1 :initial-element
#\a))
323 (generic-mixed-sequence (make-array 2 :initial-element
#\a))
324 (string (make-array 1 :element-type
'character
325 :initial-element
(code-char 255)))
326 (unsigned-sequence (make-array 1
327 :element-type
'(unsigned-byte 8)
328 :initial-contents
'(255)))
329 (signed-sequence (make-array 1
330 :element-type
'(signed-byte 8)
331 :initial-contents
'(-1))))
333 (setf (aref generic-mixed-sequence
1) 255)
335 ;; Check the slow path for generic vectors.
336 (with-open-file (stream pathname
338 :if-exists
:supersede
339 :element-type
'(unsigned-byte 8))
340 (write-sequence generic-sequence stream
))
342 (with-open-file (stream pathname
344 :if-exists
:supersede
345 :element-type
'character
)
346 (write-sequence generic-character-sequence stream
))
348 ;; Check the fast path for unsigned and signed vectors.
349 (with-open-file (stream pathname
351 :if-exists
:supersede
352 :element-type
'(unsigned-byte 8))
353 (write-sequence unsigned-sequence stream
))
355 (with-open-file (stream pathname
357 :if-exists
:supersede
358 :element-type
'(signed-byte 8))
359 (write-sequence signed-sequence stream
))
361 ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
362 ;; vector with mixed characters and bytes
364 (with-open-file (stream pathname
366 :if-exists
:supersede
367 :element-type
:default
)
368 (write-sequence unsigned-sequence stream
))
370 (with-open-file (stream pathname
372 :external-format
:latin-1
373 :if-exists
:supersede
374 :element-type
:default
)
375 (write-sequence string stream
))
377 (with-open-file (stream pathname
379 :external-format
:latin-1
380 :if-exists
:supersede
381 :element-type
:default
)
382 (write-sequence generic-mixed-sequence stream
))
384 ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
385 ;; which are incompatible with the stream element type.
386 (with-open-file (stream pathname
388 :if-exists
:supersede
389 :element-type
'(signed-byte 8))
391 (write-sequence unsigned-sequence stream
)
392 (error "WRITE-SEQUENCE didn't signal an error"))
393 (type-error (condition)
394 (assert (= (type-error-datum condition
) 255))
395 (assert (subtypep (type-error-expected-type condition
)
396 '(signed-byte 8))))))
398 (with-open-file (stream pathname
400 :if-exists
:supersede
401 :element-type
'(unsigned-byte 8))
403 (write-sequence signed-sequence stream
)
404 (error "WRITE-SEQUENCE didn't signal an error"))
405 (type-error (condition)
406 (assert (= (type-error-datum condition
) -
1))
407 (assert (subtypep (type-error-expected-type condition
)
408 '(unsigned-byte 8))))))
410 (with-open-file (stream pathname
412 :if-exists
:supersede
413 :element-type
:default
)
415 (write-sequence signed-sequence stream
)
416 (error "WRITE-SEQUENCE didn't signal an error"))
417 (type-error (condition)
418 (assert (= (type-error-datum condition
) -
1))
419 (assert (subtypep (type-error-expected-type condition
)
420 '(unsigned-byte 8))))))
422 (delete-file pathname
))
424 ;;; writing looong lines. takes way too long and way too much space
425 ;;; to test on 64 bit platforms
426 #-
#.
(cl:if
(cl:= sb-vm
:n-word-bits
64) '(and) '(or))
428 (defun write-n-chars (n stream
)
429 (format t
"~&/writing ~D chars on a single line~%" n
)
432 do
(write-char #\x stream
))
436 (let ((test "long-lines-write-test.tmp"))
438 (with-open-file (f test
440 :external-format
:ascii
441 :element-type
'character
442 :if-does-not-exist
:create
443 :if-exists
:supersede
)
444 (write-n-chars (+ most-positive-fixnum
7) f
))
445 (when (probe-file test
)
446 (delete-file test
)))))
448 ;;; read-sequence misreported the amount read and lost position
449 (let ((string (make-array (* 3 sb-impl
::+ansi-stream-in-buffer-length
+)
450 :element-type
'character
)))
451 (dotimes (i (length string
))
452 (setf (char string i
) (code-char (mod i char-code-limit
))))
453 (with-open-file (f "read-sequence-character-test-data.tmp"
454 :if-exists
:supersede
456 :external-format
:utf-8
)
457 (write-sequence string f
))
459 (with-open-file (f "read-sequence-character-test-data.tmp"
460 :if-does-not-exist
:error
462 :external-format
:utf-8
)
463 (let ((buffer (make-array 128 :element-type
'character
))
465 (with-output-to-string (datum)
466 (loop for n-read
= (read-sequence buffer f
)
467 do
(write-sequence buffer datum
:start
0 :end n-read
)
468 (assert (<= (incf total n-read
) (length string
)))
469 while
(and (= n-read
128))))))))
470 (assert (equal copy string
)))
471 (delete-file "read-sequence-character-test-data.tmp"))
473 ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
474 ;;; target was an ANSI stream, but it could be a user-defined stream,
475 ;;; e.g., a SLIME stream.
476 (defclass user-output-stream
(fundamental-output-stream)
479 (let ((*stream
* (make-instance 'user-output-stream
)))
480 (declare (special *stream
*))
481 (with-open-stream (stream (make-synonym-stream '*stream
*))
482 (assert (output-stream-p stream
))))
484 (defclass user-input-stream
(fundamental-input-stream)
487 (let ((*stream
* (make-instance 'user-input-stream
)))
488 (declare (special *stream
*))
489 (with-open-stream (stream (make-synonym-stream '*stream
*))
490 (assert (input-stream-p stream
))))