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 ;;; Until sbcl-0.6.11.31, we didn't have an N-BIN method for
15 ;;; CONCATENATED-STREAM, so stuff like this would fail.
16 (with-test (:name
(concatenated-stream read-sequence
1))
17 (let ((stream (make-concatenated-stream (make-string-input-stream "Demo")))
18 (buffer (make-string 4)))
19 (read-sequence buffer stream
)))
21 ;;; test for the new N-BIN method doing what it's supposed to
22 (with-test (:name
(concatenated-stream read-sequence
2))
23 (let* ((substrings (list "This " "is " "a " ""
24 "test of concatenated streams behaving "
25 "as ordinary streams do under READ-SEQUENCE. "
26 (make-string 140041 :initial-element
#\%
)
27 "For any size of read.."
28 (make-string 4123 :initial-element
#\.
)
29 "they should give the same results."
30 (make-string (expt 2 14) :initial-element
#\
*)
31 "There should be no differences."))
32 (substreams (mapcar #'make-string-input-stream substrings
))
33 (concatenated-stream (apply #'make-concatenated-stream substreams
))
34 (concatenated-string (apply #'concatenate
'string substrings
))
35 (stream (make-string-input-stream concatenated-string
))
37 (buffer-1 (make-string max-n-to-read
))
38 (buffer-2 (make-string max-n-to-read
)))
40 (let* ((n-to-read (random max-n-to-read
))
41 (n-actually-read-1 (read-sequence buffer-1
44 (n-actually-read-2 (read-sequence buffer-2
47 ;; (format t "buffer-1=~S~%buffer-2=~S~%" buffer-1 buffer-2)
48 (assert (= n-actually-read-1 n-actually-read-2
))
49 (assert (string= buffer-1 buffer-2
50 :end1 n-actually-read-1
51 :end2 n-actually-read-2
))
52 (unless (= n-actually-read-1 n-to-read
)
53 (assert (< n-actually-read-1 n-to-read
))
56 ;;; Entomotomy PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM bug, fixed by
57 ;;; MRD patch sbcl-devel 2002-11-02 merged ca. sbcl-0.7.9.32...
58 (with-test (:name
(peek-char :wrongly-echos-to echo-stream
))
60 (with-output-to-string (out)
63 (make-string-input-stream "ab cd e df s]") out
)))
64 ;; (Before the fix, the result had a trailing #\] in it.)
67 ;;; ...and a missing wrinkle in the original patch, dealing with
68 ;;; PEEK-CHAR/UNREAD-CHAR on ECHO-STREAMs, fixed by MRD patch
69 ;;; sbcl-devel 2002-11-18, merged ca. sbcl-0.7.9.66
70 (with-test (:name
(unread-char peek-char echo-stream
))
72 (let* ((in-stream (make-string-input-stream "abc"))
73 (out-stream (make-string-output-stream))
74 (echo-stream (make-echo-stream in-stream out-stream
)))
75 (unread-char (read-char echo-stream
) echo-stream
)
76 (peek-char #\a echo-stream
)
77 (get-output-stream-string out-stream
))
78 ;; (Before the fix, the LET* expression just signalled an error.)
81 ;;; ... and yet, a little over 6 years on, echo-streams were still
82 ;;; broken when a read-char followed the unread/peek sequence. Do
83 ;;; people not actually use echo-streams? RMK, 2009-04-02.
84 (with-test (:name
(unread-char peek-char read-char echo-stream
))
86 (let* ((in-stream (make-string-input-stream "abc"))
87 (out-stream (make-string-output-stream))
88 (echo-stream (make-echo-stream in-stream out-stream
)))
89 (unread-char (read-char echo-stream
) echo-stream
)
90 (peek-char nil echo-stream
)
91 (read-char echo-stream
)
92 (get-output-stream-string out-stream
))
93 ;; before ca. 1.0.27.18, the LET* returned "aa"
96 ;;; Reported by Fredrik Sandstrom to sbcl-devel 2005-05-17 ("Bug in
98 ;;; Description: In (peek-char nil s nil foo), if foo happens to be
99 ;;; the same character that peek-char returns, the character is
100 ;;; removed from the input stream, as if read by read-char.
101 (with-test (:name
(peek-char :eof-value
))
102 (assert (equal (with-input-from-string (s "123")
103 (list (peek-char nil s nil
#\
1) (read-char s
) (read-char s
)))
106 ;;; ... and verify that the fix does not break echo streams
107 (with-test (:name
(peek-char :eof-value echo-stream
))
108 (assert (string= (let ((out (make-string-output-stream)))
109 (with-open-stream (s (make-echo-stream
110 (make-string-input-stream "123")
113 (list (peek-char nil s nil
#\
1)
116 (get-output-stream-string out
)))
119 ;;; 0.7.12 doesn't advance current stream in concatenated streams
120 ;;; correctly when searching a stream for a char to read.
121 (with-test (:name
(concatenated-stream peek-char
))
122 (with-input-from-string (p "")
123 (with-input-from-string (q "foo")
124 (let* ((r (make-concatenated-stream p q
)))
125 (peek-char nil r
)))))
127 ;;; 0.7.14 and previous SBCLs don't have a working INTERACTIVE-STREAM-P
128 ;;; because it called UNIX-ISATTY, which wasn't defined.
129 (with-test (:name
(interactive-stream-p))
130 (with-input-from-string (s "a non-interactive stream")
131 (assert (not (interactive-stream-p s
)))))
133 ;;; KLUDGE: Unfortunately it's hard to find a reliably interactive
134 ;;; stream to test, since it's reasonable for these tests to be run
135 ;;; from a script, conceivably even as something like a cron job.
137 #+nil
(assert (eq (interactive-stream-p *terminal-io
*) t
))
139 ;;; FILE-POSITION should not accept NIL
140 (with-test (:name
:file-position-smoke-test
)
141 (let ((s (make-broadcast-stream)))
142 (assert-error (file-position s
(opaque-identity nil
)) type-error
)))
144 ;;; MAKE-STRING-INPUT-STREAM
146 ;;; * Observe FILE-POSITION :START and :END, and allow setting of
147 ;;; FILE-POSITION beyond the end of string, signalling END-OF-FILE only
149 (with-test (:name
(make-string-input-stream file-position
))
150 (let* ((string (copy-seq "abc"))
151 (stream (make-string-input-stream string
)))
152 (assert (char= (read-char stream
) #\a))
153 (assert (= 1 (file-position stream
)))
154 (assert (file-position stream
:start
))
155 (assert (= 0 (file-position stream
)))
156 (assert (file-position stream
:end
))
157 (assert (= (length string
) (file-position stream
)))
158 (assert (file-position stream
(1- (file-position stream
))))
159 (assert (char= (read-char stream
) #\c
))
160 (assert (file-position stream
(1- (file-position stream
))))
161 (assert (char= (read-char stream
) #\c
))
162 (assert (file-position stream
:end
))
163 (let ((eof (cons nil nil
)))
164 (assert (eq (read-char stream nil eof
) eof
)))
165 (assert (file-position stream
10))
166 ;; Avoid type mismatch warning when compiling of this file.
167 (let ((fun (checked-compile `(lambda (stream)
168 (file-position stream -
1))
170 (assert-error (funcall fun stream
) type-error
))
171 (assert-error (read-char stream
) end-of-file
)))
173 ;;; MAKE-STRING-OUTPUT-STREAM
175 ;;; * Observe FILE-POSITION :START and :END, and allow setting of
176 ;;; FILE-POSITION to an arbitrary index.
178 ;;; * END will always refer to the farthest position of stream so-far
179 ;;; seen, and setting FILE-POSITION beyond the current END will extend
180 ;;; the string/stream with uninitialized elements.
182 ;;; * Rewinding the stream works with overwriting semantics.
184 (with-test (:name
(make-string-output-stream file-position
))
185 (let ((stream (make-string-output-stream)))
186 (princ "abcd" stream
)
187 (assert (= 4 (file-position stream
)))
188 (assert (file-position stream
:start
))
189 (assert (= 0 (file-position stream
)))
191 (assert (= 1 (file-position stream
)))
192 (file-position stream
2)
193 (assert (= 2 (file-position stream
)))
195 (assert (file-position stream
:end
))
196 (assert (= 4 (file-position stream
)))
197 (assert (file-position stream
6))
198 (assert (file-position stream
4))
199 (assert (file-position stream
:end
))
200 (assert (= 6 (file-position stream
)))
201 (assert (file-position stream
4))
202 ;; Avoid type mismatch warning when compiling of this file.
203 (let ((fun (checked-compile `(lambda (stream)
204 (file-position stream -
1))
206 (assert-error (funcall fun stream
) type-error
))
208 (assert (equal "0b2d!!" (get-output-stream-string stream
)))))
210 (with-test (:name
(make-string-output-stream file-position
:lp-1839040
))
211 (let ((stream (make-string-output-stream)))
212 (dotimes (i 64) (write-char #\a stream
))
213 (file-position stream
40)
214 (write-char #\x stream
)
215 (file-position stream
39)
216 (write-char #\y stream
)
217 (file-position stream
41)
218 (write-char #\z stream
)
219 (let ((string (get-output-stream-string stream
)))
220 (assert (equal "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaayxzaaaaaaaaaaaaaaaaaaaaaa" string
))))
221 (let ((stream (make-string-output-stream)))
222 (dotimes (i 64) (write-char #\a stream
))
223 (dotimes (i 64) (write-char #\b stream
))
224 (file-position stream
3)
225 (file-position stream
4)
226 (write-char #\x stream
)
227 (let ((string (get-output-stream-string stream
))
228 (expected (concatenate
230 (loop for i from
0 below
64 collect
(if (= i
4) #\x
#\a))
231 (loop for i from
0 below
64 collect
#\b))))
232 (assert (equal expected string
)))))
234 ;;; WITH-OUTPUT-TO-STRING (when provided with a string argument)
236 ;;; * Observe FILE-POSITION :START and :END, and allow setting of
237 ;;; FILE-POSITION to an arbitrary index. If the new position is beyond
238 ;;; the end of string and the string is adjustable the string will be
239 ;;; implicitly extended, otherwise an error will be signalled. The
240 ;;; latter case is provided for in the code, but not currently
241 ;;; excercised since SBCL fill-pointer arrays are always (currently)
244 ;;; * END will refer to the ARRAY-TOTAL-SIZE of string, not
245 ;;; FILL-POINTER, since by definition the FILE-POSITION will always be
246 ;;; a FILL-POINTER, so that would be of limited use.
248 ;;; * Rewinding the stream works with overwriting semantics.
250 #+nil
(let ((str (make-array 0
251 :element-type
'character
254 (with-output-to-string (stream str
)
255 (princ "abcd" stream
)
256 (assert (= 4 (file-position stream
)))
257 (assert (file-position stream
:start
))
258 (assert (= 0 (file-position stream
)))
260 (assert (= 1 (file-position stream
)))
261 (file-position stream
2)
262 (assert (= 2 (file-position stream
)))
264 (assert (file-position stream
:end
))
265 (assert (= 4 (file-position stream
)))
266 (multiple-value-bind (val cond
) (ignore-errors (file-position stream -
1))
268 (assert (typep cond
'error
)))
269 (multiple-value-bind (val cond
) (ignore-errors (file-position stream
6))
271 (assert (typep cond
'error
)))
272 (assert (equal "0b2d" str
))))
274 (with-test (:name
(with-output-to-string file-position
))
275 (let ((str (make-array 0
276 :element-type
'character
279 (with-output-to-string (stream str
)
280 (princ "abcd" stream
)
281 (assert (= 4 (file-position stream
)))
282 (assert (file-position stream
:start
))
283 (assert (= 0 (file-position stream
)))
285 (assert (= 1 (file-position stream
)))
286 (file-position stream
2)
287 (assert (= 2 (file-position stream
)))
289 (assert (file-position stream
:end
))
290 (assert (= 4 (file-position stream
)))
291 (assert (file-position stream
6))
292 (assert (file-position stream
4))
293 (assert (file-position stream
:end
))
294 (assert (= 6 (file-position stream
)))
295 (assert (file-position stream
4))
296 ;; Avoid type mismatch warning when compiling of this file.
297 (let ((fun (checked-compile `(lambda (stream)
298 (file-position stream -
1))
300 (assert-error (funcall fun stream
) type-error
))
302 (assert (equal "0b2d!!" str
)))))
304 ;;; MAKE-STRING-OUTPUT-STREAM and WITH-OUTPUT-TO-STRING take an
305 ;;; :ELEMENT-TYPE keyword argument
306 (with-test (:name
(make-string-output-stream with-output-to-string
:element-type
))
307 (macrolet ((frob (element-type-form expect
&optional
(expect2 expect
))
309 (let ((s (with-output-to-string
310 (s nil
,@(when element-type-form
311 `(:element-type
,element-type-form
))))))
312 (assert (typep s
'(simple-array ,expect
(0)))))
313 (let ((s (get-output-stream-string
314 (make-string-output-stream
315 ,@(when element-type-form
316 `(:element-type
,element-type-form
))))))
317 (assert (typep s
'(simple-array ,expect2
(0))))))))
318 ;; If you pass NIL as element-type, note that there seems to be no requirement
319 ;; to produce a stream that can *accept* only characters of that type.
320 ;; We produce a CHARACTER-STRING-OUTPUT-STREAM if you do something so pointless.
322 (frob 'character character
)
323 (frob 'base-char base-char
)
324 ;; I literally do not care why these results differ.
325 (frob 'nil base-char character
)))
327 (with-test (:name
(make-string-output-stream :element-type
:bogosity
))
328 (assert-error (make-string-output-stream :element-type
'real
)))
330 (with-test (:name
(read-byte :element-type
:eof-value
))
331 (with-open-file (s #-win32
"/dev/null" #+win32
"nul" :element-type
'(signed-byte 48))
332 (assert (eq :eof
(read-byte s nil
:eof
)))))
334 (with-test (:name
(echo-stream read-sequence
1))
335 (let* ((is (make-string-input-stream "foo"))
336 (os (make-string-output-stream))
337 (s (make-echo-stream is os
))
338 (sequence (copy-seq "abcdef")))
339 (assert (= (read-sequence sequence s
) 3))
340 (assert (string= sequence
"foodef"))
341 (assert (string= (get-output-stream-string os
) "foo"))))
343 (with-test (:name
(echo-stream read-sequence
2))
344 (let* ((is (make-string-input-stream "foo"))
345 (os (make-string-output-stream))
346 (s (make-echo-stream is os
))
347 (sequence (copy-seq "abcdef")))
348 (assert (char= #\f (read-char s
)))
349 (assert (= (read-sequence sequence s
) 2))
350 (assert (string= sequence
"oocdef"))
351 (assert (string= (get-output-stream-string os
) "foo"))))
353 (with-test (:name
(echo-stream read-sequence
3))
354 (let* ((is (make-string-input-stream "foo"))
355 (os (make-string-output-stream))
356 (s (make-echo-stream is os
))
357 (sequence (copy-seq "abcdef")))
358 (assert (char= #\f (read-char s
)))
360 (assert (= (read-sequence sequence s
) 3))
361 (assert (string= sequence
"foodef"))
362 (assert (string= (get-output-stream-string os
) "foo"))))
364 (with-test (:name
(with-standard-io-syntax open
))
365 (with-standard-io-syntax
366 (open #-win32
"/dev/null" #+win32
"nul" )))
368 ;;; PEEK-CHAR T uses whitespace[2]
369 (with-test (:name
(peek-char :whitespace
[2]))
370 (let ((*readtable* (copy-readtable)))
371 (assert (char= (peek-char t (make-string-input-stream " a")) #\a))
372 (set-syntax-from-char #\Space #\a)
373 (assert (char= (peek-char t (make-string-input-stream " a")) #\Space))))
375 (with-test (:name :whitespace[2]p-is-type-safe
)
376 (let ((fun (checked-compile `(lambda () (sb-impl::whitespace
[2]p :potato *readtable*))
378 (assert-error (funcall fun) type-error)))
380 ;;; It is actually easier to run into the problem exercised by this
381 ;;; test with sockets, due to their delays between availabilities of
382 ;;; data. However edgy the case may be for normal files, however,
383 ;;; there is still a case to be found in which CL:LISTEN answers
386 ;;; This test assumes that buffering is still done until a buffer of
387 ;;; SB-IMPL::+BYTES-PER-BUFFER+ bytes is filled up, that the buffer may
388 ;;; immediately be completely filled for normal files, and that the
389 ;;; buffer-fill routine is responsible for figuring out when we've
391 (with-test (:name (stream :listen-vs-select))
392 (let ((listen-testfile-name (scratch-file-name))
393 ;; If non-NIL, size (in bytes) of the file that will exercise
394 ;; the LISTEN problem.
395 (bytes-per-buffer-sometime
396 (and (boundp 'sb-impl::+bytes-per-buffer+)
397 (symbol-value 'sb-impl::+bytes-per-buffer+))))
398 (when bytes-per-buffer-sometime
401 (with-open-file (stream listen-testfile-name
402 :direction :output :if-exists :error
403 :element-type '(unsigned-byte 8))
404 (dotimes (n bytes-per-buffer-sometime)
405 (write-byte 113 stream)))
406 (with-open-file (stream listen-testfile-name
407 :direction :input :element-type '(unsigned-byte 8))
408 (dotimes (n bytes-per-buffer-sometime)
410 (assert (not (listen stream)))))
411 (ignore-errors (delete-file listen-testfile-name))))))
413 (with-test (:name :bug-395)
414 (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char)))
416 (assert (equal (coerce "foo" 'base-string) v))))
418 ;;; Circa 1.0.27.18, echo-streams were changed somewhat, so that
419 ;;; unread-char on an echo-stream propagated the character down to the
420 ;;; echo-stream's input stream. (All other implementations but CMUCL
421 ;;; seemed to do this). The most useful argument for this behavior
422 ;;; involves cases where an input operation on an echo-stream finishes
423 ;;; up by unreading a delimiter, and the user wants to proceed to use the
424 ;;; underlying stream, e.g.,
425 (with-test (:name (echo-stream unread-char))
427 (with-input-from-string (in "foo\"bar\"")
428 (with-open-stream (out (make-broadcast-stream))
429 (with-open-stream (echo (make-echo-stream in out))
432 ;; Before ca 1.0.27.18, the implicit UNREAD-CHAR at the end of
433 ;; the first READ wouldn't get back to IN, so the second READ
434 ;; returned BAR, not "BAR" (and then subsequent reads would
438 ;; WITH-INPUT-FROM-STRING would multiply evaluate the :END argument,
439 ;; and so previously this returned the symbol A, not ABC.
440 (with-test (:name (with-input-from-string :end :once-only))
441 (assert (eq (let ((s "ABCDEFG")
443 (symbol-macrolet ((ptr (decf i 2)))
444 (with-input-from-string (stream s :end ptr)
449 ;; CHECKED-COMPILE avoids the compile-time warning when
450 ;; loading this file.
451 (let ((fun (checked-compile `(lambda () ,form) :allow-warnings t)))
452 (assert-error (funcall fun) type-error))))
454 (with-test (:name (read-sequence sequence type-error))
455 (test `(read-sequence 1 (make-string-input-stream "foo"))))
457 (with-test (:name (write-sequence sequence type-error))
458 (test `(write-sequence 1 (make-string-output-stream)))))
460 (with-test (:name :fill-pointer-stream-charpos)
461 (let ((string (make-array 3 :initial-contents (format nil "~%ab")
462 :element-type 'character :fill-pointer 1)))
463 (with-output-to-string (stream string)
465 (assert (equal string (string #\Newline)))))
467 (with-test (:name (:fill-pointer-stream-charpos :displaced))
468 (let* ((displaced (format nil "~%abc"))
469 (string (make-array 3 :displaced-to displaced
470 :displaced-index-offset 1
471 :element-type (array-element-type displaced)
473 (with-output-to-string (stream string)
475 (assert (equal string ""))))
478 (with-test (:name (:write-char-base-char-stream-reject-non-base-char))
480 (write-char (code-char 1000)
481 (make-string-output-stream :element-type 'base-char))))
484 (with-test (:name (:write-string-base-char-stream-reject-non-base-char))
486 (write-string (make-string 1 :initial-element (code-char 1000))
487 (make-string-output-stream :element-type 'base-char))))
490 (with-test (:name (:default-char-stream-resets))
491 (sb-impl::%with-output-to-string (s)
493 (write-char (code-char 1000) s)
494 (assert (equal (type-of (get-output-stream-string s))
495 '(simple-array character (1))))
497 ;; result type reverts back to simple-base-string after get-output-stream-string
498 (assert (equal (type-of (get-output-stream-string s))
499 '(simple-base-string 1))))))
501 (with-test (:name :with-input-from-string-nowarn)
502 (checked-compile '(lambda ()
503 (with-input-from-string (s "muffin")))))
505 (with-test (:name :with-input-from-string-declarations)
506 (checked-compile-and-assert
509 (with-input-from-string (x string)
510 (declare (optimize safety))
514 (defun input-from-dynamic-extent-stream ()
515 (handler-case (with-input-from-string (stream "#w") (read stream nil nil))
517 (format nil "~A" condition))))
518 (compile 'input-from-dynamic-extent-stream)
519 (with-test (:name :with-input-from-string-signal-stream-error)
520 (assert (search "unavailable" (input-from-dynamic-extent-stream))))
522 (with-test (:name :closeable-broadcast-stream)
523 (let ((b (make-broadcast-stream)))
525 (assert (not (open-stream-p b)))
526 (assert-error (write-string "test" b))))
528 (defvar *some-stream*)
529 (with-test (:name :closeable-synonym-stream)
530 (let ((*some-stream* (make-string-input-stream "hola")))
531 (let ((syn (make-synonym-stream '*some-stream*)))
532 (assert (eql (read-char syn) #\h))
534 (assert (not (open-stream-p syn)))
535 (assert-error (read-char syn))
536 (close syn) ; no error
537 (assert (eql (read-char *some-stream*) #\o)))))