1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / stream.impure.lisp
1 ;;;; tests related to Lisp streams
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (load "assertoid.lisp")
15 (use-package "ASSERTOID")
16
17 ;;; type errors for inappropriate stream arguments, fixed in
18 ;;; sbcl-0.7.8.19
19 (locally
20     (declare (optimize (safety 3)))
21   (assert (raises-error? (make-two-way-stream (make-string-output-stream)
22                                               (make-string-output-stream))
23                          type-error))
24   (assert (raises-error? (make-two-way-stream (make-string-input-stream "foo")
25                                               (make-string-input-stream "bar"))
26                          type-error))
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))
35                          type-error))
36   (assert (raises-error? (make-echo-stream (make-string-input-stream "foo")
37                                            (make-string-input-stream "bar"))
38                          type-error))
39   (assert (raises-error? (make-concatenated-stream
40                           (make-string-output-stream)
41                           (make-string-input-stream "foo"))
42                          type-error)))
43
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)))
51
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)))
56
57 \f
58 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
59 (let ((p "signed-byte-8-test.data"))
60   (with-open-file (s p
61                      :direction :output
62                      :element-type '(unsigned-byte 8)
63                      :if-exists :supersede)
64     (write-byte 255 s))
65   (with-open-file (s p :element-type '(signed-byte 8))
66     (assert (= (read-byte s) -1)))
67   (delete-file p))
68 \f
69 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
70 ;;; Milan Zamazal)
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))))
76   (close stream)
77   (delete-file p))
78 \f
79 (assert (raises-error? (read-byte (make-string-input-stream "abc"))
80                        type-error))
81 (assert (raises-error? (with-open-file (s "/dev/zero")
82                          (read-byte s))
83                        type-error))
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)
90     (read s)
91     (with-standard-io-syntax
92       (prin1 'insert s)))
93   (with-open-file (s p)
94     (let ((line (read-line s))
95           (want "THESE INSERTMBOLS"))
96       (unless (equal line want)
97         (error "wanted ~S, got ~S" want line))))
98   (delete-file p))
99 \f
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)
104     (format s "1")
105     (finish-output s)
106     (file-position s :start)
107     (assert (char= (read-char s) #\1)))
108   (delete-file p))
109 \f
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)))
116   (write-char #\a s)
117   (assert (not (file-position s 1)))
118   (assert (= 0 (file-position s))))
119
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))
127       (write-char #\a s)
128       (assert (= 1 (file-position s))) ; unicode...
129       (assert (file-position s 0))))
130   (delete-file p))
131
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)
136                `(progn
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)))))
142     (unwind-protect
143          (progn
144            (with-open-file (f test :direction :output)
145              (write-line "test" f))
146            (test-mode :append)
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)
151            (test-mode :rename)
152            (test-mode :rename-and-delete))
153       (when (probe-file test)
154         (delete-file test)))))
155
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")
160                         (num-bytes 10)
161                         (bytes (if (eq type 'signed-byte)
162                                    (loop :repeat num-bytes :collect
163                                          (- (random (ash 1 size))
164                                             (ash 1 (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))
169     (dolist (byte bytes)
170       (write-byte byte foo)))
171   (unwind-protect
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))
184 \f
185 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
186 ;;; contain a stream element.
187 ;;;
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
191 ;;; READ-N-BYTES:
192 ;;;
193 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
194 ;;;
195 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
196 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
197
198 (let ((pathname "read-sequence.data"))
199
200   ;; Create the binary data.
201   (with-open-file (stream pathname
202                           :direction :output
203                           :if-exists :supersede
204                           :element-type '(unsigned-byte 8))
205     (write-byte 255 stream))
206
207   ;; Check the slow path for generic vectors.
208   (let ((sequence (make-array 1)))
209     (with-open-file (stream pathname
210                             :direction :input
211                             :element-type '(unsigned-byte 8))
212     (read-sequence sequence stream)
213     (assert (equalp sequence #(255)))))
214
215   (let ((sequence (make-array 1)))
216     (with-open-file (stream pathname
217                             :direction :input
218                             :external-format :latin-1
219                             :element-type 'character)
220       (read-sequence sequence stream)
221       (assert (equalp sequence #(#.(code-char 255))))))
222
223   ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
224   ;; 8) vectors.
225   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
226     (with-open-file (stream pathname
227                             :direction :input
228                             :element-type '(unsigned-byte 8))
229       (read-sequence sequence stream)
230       (assert (equalp sequence #(255)))))
231
232   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
233     (with-open-file (stream pathname
234                             :direction :input
235                             :element-type '(signed-byte 8))
236     (read-sequence sequence stream)
237     (assert (equalp sequence #(-1)))))
238
239   ;; A bivalent stream can be read to a unsigned-byte vector, a
240   ;; string, or a generic vector
241
242   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
243     (with-open-file (stream pathname
244                             :direction :input
245                             :element-type :default)
246       (read-sequence sequence stream)
247       (assert (equalp sequence #(255)))))
248
249   (let ((sequence (make-array 1 :element-type 'character)))
250     (with-open-file (stream pathname
251                             :direction :input
252                             :external-format :latin-1
253                             :element-type :default)
254       (read-sequence sequence stream)
255       (assert (equalp sequence #(#.(code-char 255))))))
256
257   (let ((sequence (make-array 1)))
258     (with-open-file (stream pathname
259                             :direction :input
260                             :external-format :latin-1
261                             :element-type :default)
262       (read-sequence sequence stream)
263       (assert (equalp sequence #(#.(code-char 255))))))
264
265   ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
266   ;; stream) pairs.
267
268   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
269     (with-open-file (stream pathname
270                             :direction :input
271                             :element-type '(unsigned-byte 8))
272       (handler-case (progn
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)))))))
279
280   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
281     (with-open-file (stream pathname
282                             :direction :input
283                             :element-type '(signed-byte 8))
284       (handler-case (progn
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)))))))
291
292   ;; Can't read a signed-byte from a bivalent stream
293
294   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
295     (with-open-file (stream pathname
296                             :direction :input
297                             :external-format :latin1
298                             :element-type :default)
299       (handler-case (progn
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)))))))
306   (delete-file pathname))
307 \f
308 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
309 ;;; write a sequence element.
310 ;;;
311 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
312 ;;; or slow paths are being taken for each element type.  See the
313 ;;; READ-SEQUENCE tests above for more information.
314 ;;;
315 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
316
317 (let ((pathname "write-sequence.data")
318       (generic-sequence (make-array 1 :initial-contents '(255)))
319       (generic-character-sequence (make-array 1 :initial-element #\a))
320       (generic-mixed-sequence (make-array 2 :initial-element #\a))
321       (string (make-array 1 :element-type 'character
322                           :initial-element (code-char 255)))
323       (unsigned-sequence (make-array 1
324                                      :element-type '(unsigned-byte 8)
325                                      :initial-contents '(255)))
326       (signed-sequence (make-array 1
327                                    :element-type '(signed-byte 8)
328                                    :initial-contents '(-1))))
329
330   (setf (aref generic-mixed-sequence 1) 255)
331
332   ;; Check the slow path for generic vectors.
333   (with-open-file (stream pathname
334                            :direction :output
335                            :if-exists :supersede
336                            :element-type '(unsigned-byte 8))
337     (write-sequence generic-sequence stream))
338
339   (with-open-file (stream pathname
340                           :direction :output
341                           :if-exists :supersede
342                           :element-type 'character)
343     (write-sequence generic-character-sequence stream))
344
345   ;; Check the fast path for unsigned and signed vectors.
346   (with-open-file (stream pathname
347                           :direction :output
348                           :if-exists :supersede
349                           :element-type '(unsigned-byte 8))
350     (write-sequence unsigned-sequence stream))
351
352   (with-open-file (stream pathname
353                           :direction :output
354                           :if-exists :supersede
355                           :element-type '(signed-byte 8))
356     (write-sequence signed-sequence stream))
357
358   ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
359   ;; vector with mixed characters and bytes
360
361   (with-open-file (stream pathname
362                           :direction :output
363                           :if-exists :supersede
364                           :element-type :default)
365     (write-sequence unsigned-sequence stream))
366
367   (with-open-file (stream pathname
368                           :direction :output
369                           :external-format :latin-1
370                           :if-exists :supersede
371                           :element-type :default)
372     (write-sequence string stream))
373
374   (with-open-file (stream pathname
375                           :direction :output
376                           :external-format :latin-1
377                           :if-exists :supersede
378                           :element-type :default)
379     (write-sequence generic-mixed-sequence stream))
380
381   ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
382   ;; which are incompatible with the stream element type.
383   (with-open-file (stream pathname
384                           :direction :output
385                           :if-exists :supersede
386                           :element-type '(signed-byte 8))
387     (handler-case (progn
388                     (write-sequence unsigned-sequence stream)
389                     (error "WRITE-SEQUENCE didn't signal an error"))
390       (type-error (condition)
391         (assert (= (type-error-datum condition) 255))
392         (assert (subtypep (type-error-expected-type condition)
393                           '(signed-byte 8))))))
394
395   (with-open-file (stream pathname
396                           :direction :output
397                           :if-exists :supersede
398                           :element-type '(unsigned-byte 8))
399     (handler-case (progn
400                     (write-sequence signed-sequence stream)
401                     (error "WRITE-SEQUENCE didn't signal an error"))
402       (type-error (condition)
403         (assert (= (type-error-datum condition) -1))
404         (assert (subtypep (type-error-expected-type condition)
405                           '(unsigned-byte 8))))))
406
407   (with-open-file (stream pathname
408                           :direction :output
409                           :if-exists :supersede
410                           :element-type :default)
411     (handler-case (progn
412                     (write-sequence signed-sequence stream)
413                     (error "WRITE-SEQUENCE didn't signal an error"))
414       (type-error (condition)
415         (assert (= (type-error-datum condition) -1))
416         (assert (subtypep (type-error-expected-type condition)
417                           '(unsigned-byte 8))))))
418
419   (delete-file pathname))
420
421 ;;; writing looong lines. takes way too long and way too much space
422 ;;; to test on 64 bit platforms
423 #-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or))
424 (progn
425   (defun write-n-chars (n stream)
426     (format t "~&/writing ~D chars on a single line~%" n)
427     (finish-output t)
428     (loop repeat n
429        do (write-char #\x stream))
430     (terpri stream)
431     n)
432
433   (let ((test "long-lines-write-test.tmp"))
434     (unwind-protect
435          (with-open-file (f test
436                             :direction :output
437                             :external-format :ascii
438                             :element-type 'character
439                             :if-does-not-exist :create
440                             :if-exists :supersede)
441          (write-n-chars (+ most-positive-fixnum 7) f))
442       (when (probe-file test)
443         (delete-file test)))))
444
445 ;;; read-sequence misreported the amount read and lost position
446 (let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
447                           :element-type 'character)))
448   (dotimes (i (length string))
449     (setf (char string i) (code-char (mod i char-code-limit))))
450   (with-open-file (f "read-sequence-character-test-data.tmp"
451                      :if-exists :supersede
452                      :direction :output
453                      :external-format :utf-8)
454     (write-sequence string f))
455   (let ((copy
456          (with-open-file (f "read-sequence-character-test-data.tmp"
457                             :if-does-not-exist :error
458                             :direction :input
459                             :external-format :utf-8)
460            (let ((buffer (make-array 128 :element-type 'character))
461                  (total 0))
462              (with-output-to-string (datum)
463                (loop for n-read = (read-sequence buffer f)
464                      do (write-sequence buffer datum :start 0 :end n-read)
465                         (assert (<= (incf total n-read) (length string)))
466                      while (and (= n-read 128))))))))
467     (assert (equal copy string)))
468   (delete-file "read-sequence-character-test-data.tmp"))
469
470 ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
471 ;;; target was an ANSI stream, but it could be a user-defined stream,
472 ;;; e.g., a SLIME stream.
473 (defclass user-output-stream (fundamental-output-stream)
474   ())
475
476 (let ((*stream* (make-instance 'user-output-stream)))
477   (declare (special *stream*))
478   (with-open-stream (stream (make-synonym-stream '*stream*))
479     (assert (output-stream-p stream))))
480
481 (defclass user-input-stream (fundamental-input-stream)
482   ())
483
484 (let ((*stream* (make-instance 'user-input-stream)))
485   (declare (special *stream*))
486   (with-open-stream (stream (make-synonym-stream '*stream*))
487     (assert (input-stream-p stream))))
488
489 ;;; READ-LINE on ANSI-STREAM did not return T for the last line
490 ;;; (reported by Yoshinori Tahara)
491 (let ((pathname "test-read-line-eol"))
492   (with-open-file (out pathname :direction :output :if-exists :supersede)
493     (format out "a~%b"))
494   (let ((result (with-open-file (in pathname)
495                   (list (multiple-value-list (read-line in nil nil))
496                         (multiple-value-list (read-line in nil nil))
497                         (multiple-value-list (read-line in nil nil))))))
498     (delete-file pathname)
499     (assert (equal result '(("a" nil) ("b" t) (nil t))))))
500
501 ;;; READ-LINE used to work on closed streams because input buffers were left in place
502 (with-test (:name :bug-425)
503   ;; Normal close
504   (let ((f (open "stream.impure.lisp" :direction :input)))
505     (assert (stringp (read-line f)))
506     (close f)
507     (assert (eq :fii
508                 (handler-case
509                     (read-line f)
510                   (sb-int:closed-stream-error () :fii)))))
511   ;; Abort
512   (let ((f (open "stream.impure.lisp" :direction :input)))
513     (assert (stringp (read-line f nil nil)))
514     (close f :abort t)
515     (assert (eq :faa
516                 (handler-case
517                     (read-line f)
518                   (sb-int:closed-stream-error () :faa))))))
519 \f
520 ;;; success