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 (assert (string= (read-line s) "THESE INSERTMBOLS")))
97 ;;; :DIRECTION :IO didn't work on non-existent pathnames
98 (let ((p "direction-io-test"))
99 (ignore-errors (delete-file p))
100 (with-open-file (s p :direction :io)
103 (file-position s :start)
104 (assert (char= (read-char s) #\1)))
107 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
108 (assert (= 0 (file-position (make-broadcast-stream))))
109 (assert (file-position (make-broadcast-stream) :start))
110 (assert (file-position (make-broadcast-stream) 0))
111 (assert (not (file-position (make-broadcast-stream) 1)))
112 (let ((s (make-broadcast-stream)))
114 (assert (not (file-position s 1)))
115 (assert (= 0 (file-position s))))
117 (let ((p "broadcast-stream-test"))
118 (ignore-errors (delete-file p))
119 (with-open-file (f p :direction :output)
120 (let ((s (make-broadcast-stream f)))
121 (assert (= 0 (file-position s)))
122 (assert (file-position s :start))
123 (assert (file-position s 0))
125 (assert (= 1 (file-position s))) ; unicode...
126 (assert (file-position s 0))))
129 ;;; CLOSING a non-new streams should not delete them, and superseded
130 ;;; files should be restored.
131 (let ((test "test-file-for-close-should-not-delete"))
132 (macrolet ((test-mode (mode)
134 (catch :close-test-exit
135 (with-open-file (f test :direction :output :if-exists ,mode)
136 (write-line "test" f)
137 (throw :close-test-exit t)))
138 (assert (and (probe-file test) ,mode)))))
141 (with-open-file (f test :direction :output)
142 (write-line "test" f))
144 (test-mode :overwrite)
145 ;; FIXME: We really should recover supersede files as well, according to
146 ;; CLOSE in CLHS, but at the moment we don't.
147 ;; (test-mode :supersede)
149 (test-mode :rename-and-delete))
150 (when (probe-file test)
151 (delete-file test)))))
153 ;;; test for read-write invariance of signed bytes, from Bruno Haible
154 ;;; cmucl-imp 2004-09-06
155 (defun bin-stream-test (&key (size (integer-length most-positive-fixnum))
156 (type 'unsigned-byte) (file-name "stream-impure.tmp")
158 (bytes (if (eq type 'signed-byte)
159 (loop :repeat num-bytes :collect
160 (- (random (ash 1 size))
162 (loop :repeat num-bytes :collect
163 (random (ash 1 size))))))
164 (with-open-file (foo file-name :direction :output :if-exists :supersede
165 :element-type (list type size))
167 (write-byte byte foo)))
169 (with-open-file (foo file-name :direction :input
170 :element-type (list type size))
171 (list (stream-element-type foo) (file-length foo) bytes
172 (loop :for byte :in bytes :for nb = (read-byte foo) :collect nb
173 :unless (= nb byte) :do
174 (flet ((by-out (sz by)
175 (format nil "~v,'0,' ,4:b"
176 (+ sz (floor sz 4)) by)))
177 (error "~& * [(~s ~s)] ~a != ~a~%" type size
178 (by-out size byte) (by-out size nb))))))
179 (delete-file file-name)))
180 (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte))
182 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
183 ;;; contain a stream element.
185 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
186 ;;; or slow paths are being taken for each element type. To check the
187 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
190 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
192 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
193 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
195 (let ((pathname "read-sequence.data"))
197 ;; Create the binary data.
198 (with-open-file (stream pathname
200 :if-exists :supersede
201 :element-type '(unsigned-byte 8))
202 (write-byte 255 stream))
204 ;; Check the slow path for generic vectors.
205 (let ((sequence (make-array 1)))
206 (with-open-file (stream pathname
208 :element-type '(unsigned-byte 8))
209 (read-sequence sequence stream)
210 (assert (equalp sequence #(255)))))
212 ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
214 (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
215 (with-open-file (stream pathname
217 :element-type '(unsigned-byte 8))
218 (read-sequence sequence stream)
219 (assert (equalp sequence #(255)))))
221 (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
222 (with-open-file (stream pathname
224 :element-type '(signed-byte 8))
225 (read-sequence sequence stream)
226 (assert (equalp sequence #(-1)))))
228 ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
231 (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
232 (with-open-file (stream pathname
234 :element-type '(unsigned-byte 8))
236 (read-sequence sequence stream)
237 (error "READ-SEQUENCE didn't signal an error"))
238 (type-error (condition)
239 (assert (= (type-error-datum condition) 255))
240 (assert (subtypep (type-error-expected-type condition)
241 '(signed-byte 8)))))))
243 (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
244 (with-open-file (stream pathname
246 :element-type '(signed-byte 8))
248 (read-sequence sequence stream)
249 (error "READ-SEQUENCE didn't signal an error"))
250 (type-error (condition)
251 (assert (= (type-error-datum condition) -1))
252 (assert (subtypep (type-error-expected-type condition)
253 '(unsigned-byte 8))))))))
255 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
256 ;;; write a sequence element.
258 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
259 ;;; or slow paths are being taken for each element type. See the
260 ;;; READ-SEQUENCE tests above for more information.
262 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
264 (let ((pathname "write-sequence.data")
265 (generic-sequence (make-array 1 :initial-contents '(255)))
266 (unsigned-sequence (make-array 1
267 :element-type '(unsigned-byte 8)
268 :initial-contents '(255)))
269 (signed-sequence (make-array 1
270 :element-type '(signed-byte 8)
271 :initial-contents '(-1))))
272 ;; Check the slow path for generic vectors.
273 (with-open-file (stream pathname
275 :if-exists :supersede
276 :element-type '(unsigned-byte 8))
277 (write-sequence generic-sequence stream))
279 ;; Check the fast path for unsigned and signed vectors.
280 (with-open-file (stream pathname
282 :if-exists :supersede
283 :element-type '(unsigned-byte 8))
284 (write-sequence unsigned-sequence stream))
286 (with-open-file (stream pathname
288 :if-exists :supersede
289 :element-type '(signed-byte 8))
290 (write-sequence signed-sequence stream))
292 ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
293 ;; which are incompatible with the stream element type.
294 (with-open-file (stream pathname
296 :if-exists :supersede
297 :element-type '(signed-byte 8))
299 (write-sequence unsigned-sequence stream)
300 (error "WRITE-SEQUENCE didn't signal an error"))
301 (type-error (condition)
302 (assert (= (type-error-datum condition) 255))
303 (assert (subtypep (type-error-expected-type condition)
304 '(signed-byte 8))))))
306 (with-open-file (stream pathname
308 :if-exists :supersede
309 :element-type '(unsigned-byte 8))
311 (write-sequence signed-sequence stream)
312 (error "WRITE-SEQUENCE didn't signal an error"))
313 (type-error (condition)
314 (assert (= (type-error-datum condition) -1))
315 (assert (subtypep (type-error-expected-type condition)
316 '(unsigned-byte 8)))))))