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 (open p
:direction
:output
:if-exists
:error
)))
73 (assert (null (with-open-file (s p
:direction
:output
:if-exists nil
) s
)))
74 (assert (raises-error?
75 (with-open-file (s p
:direction
:output
:if-exists
:error
))))
79 (assert (raises-error?
(read-byte (make-string-input-stream "abc"))
81 (assert (raises-error?
(with-open-file (s "/dev/zero")
84 ;;; bidirectional streams getting confused about their position
85 (let ((p "bidirectional-stream-test"))
86 (with-open-file (s p
:direction
:output
:if-exists
:supersede
)
87 (with-standard-io-syntax
88 (format s
"~S ~S ~S~%" 'these
'are
'symbols
)))
89 (with-open-file (s p
:direction
:io
:if-exists
:overwrite
)
91 (with-standard-io-syntax
94 (let ((line (read-line s
))
95 (want "THESE INSERTMBOLS"))
96 (unless (equal line want
)
97 (error "wanted ~S, got ~S" want line
))))
100 ;;; :DIRECTION :IO didn't work on non-existent pathnames
101 (let ((p "direction-io-test"))
102 (ignore-errors (delete-file p
))
103 (with-open-file (s p
:direction
:io
)
106 (file-position s
:start
)
107 (assert (char= (read-char s
) #\
1)))
110 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
111 (assert (= 0 (file-position (make-broadcast-stream))))
112 (assert (file-position (make-broadcast-stream) :start
))
113 (assert (file-position (make-broadcast-stream) 0))
114 (assert (not (file-position (make-broadcast-stream) 1)))
115 (let ((s (make-broadcast-stream)))
117 (assert (not (file-position s
1)))
118 (assert (= 0 (file-position s
))))
120 (let ((p "broadcast-stream-test"))
121 (ignore-errors (delete-file p
))
122 (with-open-file (f p
:direction
:output
)
123 (let ((s (make-broadcast-stream f
)))
124 (assert (= 0 (file-position s
)))
125 (assert (file-position s
:start
))
126 (assert (file-position s
0))
128 (assert (= 1 (file-position s
))) ; unicode...
129 (assert (file-position s
0))))
132 ;;; CLOSING a non-new streams should not delete them, and superseded
133 ;;; files should be restored.
134 (let ((test "test-file-for-close-should-not-delete"))
135 (macrolet ((test-mode (mode)
137 (catch :close-test-exit
138 (with-open-file (f test
:direction
:output
:if-exists
,mode
)
139 (write-line "test" f
)
140 (throw :close-test-exit t
)))
141 (assert (and (probe-file test
) ,mode
)))))
144 (with-open-file (f test
:direction
:output
)
145 (write-line "test" f
))
147 (test-mode :overwrite
)
148 ;; FIXME: We really should recover supersede files as well, according to
149 ;; CLOSE in CLHS, but at the moment we don't.
150 ;; (test-mode :supersede)
152 (test-mode :rename-and-delete
))
153 (when (probe-file test
)
154 (delete-file test
)))))
156 ;;; test for read-write invariance of signed bytes, from Bruno Haible
157 ;;; cmucl-imp 2004-09-06
158 (defun bin-stream-test (&key
(size (integer-length most-positive-fixnum
))
159 (type 'unsigned-byte
) (file-name "stream-impure.tmp")
161 (bytes (if (eq type
'signed-byte
)
162 (loop :repeat num-bytes
:collect
163 (- (random (ash 1 size
))
165 (loop :repeat num-bytes
:collect
166 (random (ash 1 size
))))))
167 (with-open-file (foo file-name
:direction
:output
:if-exists
:supersede
168 :element-type
(list type size
))
170 (write-byte byte foo
)))
172 (with-open-file (foo file-name
:direction
:input
173 :element-type
(list type size
))
174 (list (stream-element-type foo
) (file-length foo
) bytes
175 (loop :for byte
:in bytes
:for nb
= (read-byte foo
) :collect nb
176 :unless
(= nb byte
) :do
177 (flet ((by-out (sz by
)
178 (format nil
"~v,'0,' ,4:b"
179 (+ sz
(floor sz
4)) by
)))
180 (error "~& * [(~s ~s)] ~a != ~a~%" type size
181 (by-out size byte
) (by-out size nb
))))))
182 (delete-file file-name
)))
183 (loop for size from
2 to
40 do
(bin-stream-test :size size
:type
'signed-byte
))
185 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
186 ;;; contain a stream element.
188 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
189 ;;; or slow paths are being taken for each element type. To check the
190 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
193 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
195 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
196 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
198 (let ((pathname "read-sequence.data"))
200 ;; Create the binary data.
201 (with-open-file (stream pathname
203 :if-exists
:supersede
204 :element-type
'(unsigned-byte 8))
205 (write-byte 255 stream
))
207 ;; Check the slow path for generic vectors.
208 (let ((sequence (make-array 1)))
209 (with-open-file (stream pathname
211 :element-type
'(unsigned-byte 8))
212 (read-sequence sequence stream
)
213 (assert (equalp sequence
#(255)))))
215 (let ((sequence (make-array 1)))
216 (with-open-file (stream pathname
218 :external-format
:latin-1
219 :element-type
'character
)
220 (read-sequence sequence stream
)
221 (assert (equalp sequence
#(#.
(code-char 255))))))
223 ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
225 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
226 (with-open-file (stream pathname
228 :element-type
'(unsigned-byte 8))
229 (read-sequence sequence stream
)
230 (assert (equalp sequence
#(255)))))
232 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
233 (with-open-file (stream pathname
235 :element-type
'(signed-byte 8))
236 (read-sequence sequence stream
)
237 (assert (equalp sequence
#(-1)))))
239 ;; A bivalent stream can be read to a unsigned-byte vector, a
240 ;; string, or a generic vector
242 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
243 (with-open-file (stream pathname
245 :element-type
:default
)
246 (read-sequence sequence stream
)
247 (assert (equalp sequence
#(255)))))
249 (let ((sequence (make-array 1 :element-type
'character
)))
250 (with-open-file (stream pathname
252 :external-format
:latin-1
253 :element-type
:default
)
254 (read-sequence sequence stream
)
255 (assert (equalp sequence
#(#.
(code-char 255))))))
257 (let ((sequence (make-array 1)))
258 (with-open-file (stream pathname
260 :external-format
:latin-1
261 :element-type
:default
)
262 (read-sequence sequence stream
)
263 (assert (equalp sequence
#(#.
(code-char 255))))))
265 ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
268 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
269 (with-open-file (stream pathname
271 :element-type
'(unsigned-byte 8))
273 (read-sequence sequence stream
)
274 (error "READ-SEQUENCE didn't signal an error"))
275 (type-error (condition)
276 (assert (= (type-error-datum condition
) 255))
277 (assert (subtypep (type-error-expected-type condition
)
278 '(signed-byte 8)))))))
280 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
281 (with-open-file (stream pathname
283 :element-type
'(signed-byte 8))
285 (read-sequence sequence stream
)
286 (error "READ-SEQUENCE didn't signal an error"))
287 (type-error (condition)
288 (assert (= (type-error-datum condition
) -
1))
289 (assert (subtypep (type-error-expected-type condition
)
290 '(unsigned-byte 8)))))))
292 ;; Can't read a signed-byte from a bivalent stream
294 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
295 (with-open-file (stream pathname
297 :external-format
:latin1
298 :element-type
:default
)
300 (read-sequence sequence stream
)
301 (error "READ-SEQUENCE didn't signal an error"))
302 (type-error (condition)
303 (assert (eql (type-error-datum condition
) (code-char 255)))
304 (assert (subtypep (type-error-expected-type condition
)
305 '(signed-byte 8))))))))
307 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
308 ;;; write a sequence element.
310 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
311 ;;; or slow paths are being taken for each element type. See the
312 ;;; READ-SEQUENCE tests above for more information.
314 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
316 (let ((pathname "write-sequence.data")
317 (generic-sequence (make-array 1 :initial-contents
'(255)))
318 (generic-character-sequence (make-array 1 :initial-element
#\a))
319 (generic-mixed-sequence (make-array 2 :initial-element
#\a))
320 (string (make-array 1 :element-type
'character
321 :initial-element
(code-char 255)))
322 (unsigned-sequence (make-array 1
323 :element-type
'(unsigned-byte 8)
324 :initial-contents
'(255)))
325 (signed-sequence (make-array 1
326 :element-type
'(signed-byte 8)
327 :initial-contents
'(-1))))
329 (setf (aref generic-mixed-sequence
1) 255)
331 ;; Check the slow path for generic vectors.
332 (with-open-file (stream pathname
334 :if-exists
:supersede
335 :element-type
'(unsigned-byte 8))
336 (write-sequence generic-sequence stream
))
338 (with-open-file (stream pathname
340 :if-exists
:supersede
341 :element-type
'character
)
342 (write-sequence generic-character-sequence stream
))
344 ;; Check the fast path for unsigned and signed vectors.
345 (with-open-file (stream pathname
347 :if-exists
:supersede
348 :element-type
'(unsigned-byte 8))
349 (write-sequence unsigned-sequence stream
))
351 (with-open-file (stream pathname
353 :if-exists
:supersede
354 :element-type
'(signed-byte 8))
355 (write-sequence signed-sequence stream
))
357 ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
358 ;; vector with mixed characters and bytes
360 (with-open-file (stream pathname
362 :if-exists
:supersede
363 :element-type
:default
)
364 (write-sequence unsigned-sequence stream
))
366 (with-open-file (stream pathname
368 :external-format
:latin-1
369 :if-exists
:supersede
370 :element-type
:default
)
371 (write-sequence string stream
))
373 (with-open-file (stream pathname
375 :external-format
:latin-1
376 :if-exists
:supersede
377 :element-type
:default
)
378 (write-sequence generic-mixed-sequence stream
))
380 ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
381 ;; which are incompatible with the stream element type.
382 (with-open-file (stream pathname
384 :if-exists
:supersede
385 :element-type
'(signed-byte 8))
387 (write-sequence unsigned-sequence stream
)
388 (error "WRITE-SEQUENCE didn't signal an error"))
389 (type-error (condition)
390 (assert (= (type-error-datum condition
) 255))
391 (assert (subtypep (type-error-expected-type condition
)
392 '(signed-byte 8))))))
394 (with-open-file (stream pathname
396 :if-exists
:supersede
397 :element-type
'(unsigned-byte 8))
399 (write-sequence signed-sequence stream
)
400 (error "WRITE-SEQUENCE didn't signal an error"))
401 (type-error (condition)
402 (assert (= (type-error-datum condition
) -
1))
403 (assert (subtypep (type-error-expected-type condition
)
404 '(unsigned-byte 8))))))
406 (with-open-file (stream pathname
408 :if-exists
:supersede
409 :element-type
:default
)
411 (write-sequence signed-sequence stream
)
412 (error "WRITE-SEQUENCE didn't signal an error"))
413 (type-error (condition)
414 (assert (= (type-error-datum condition
) -
1))
415 (assert (subtypep (type-error-expected-type condition
)
416 '(unsigned-byte 8)))))))
418 ;;; writing looong lines. takes way too long and way too much space
419 ;;; to test on 64 bit platforms
420 #-
#.
(cl:if
(cl:= sb-vm
:n-word-bits
64) '(and) '(or))
422 (defun write-n-chars (n stream
)
423 (format t
"~&/writing ~D chars on a single line~%" n
)
426 do
(write-char #\x stream
))
430 (let ((test "long-lines-write-test.tmp"))
432 (with-open-file (f test
434 :external-format
:ascii
435 :element-type
'character
436 :if-does-not-exist
:create
437 :if-exists
:supersede
)
438 (write-n-chars (+ most-positive-fixnum
7) f
))
439 (when (probe-file test
)
440 (delete-file test
)))))