In the mips sigtrap hander, and for the case of a break instruction in a
[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     (assert (string= (read-line s) "THESE INSERTMBOLS")))
95   (delete-file p))
96 \f
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)
101     (format s "1")
102     (finish-output s)
103     (file-position s :start)
104     (assert (char= (read-char s) #\1)))
105   (delete-file p))
106 \f
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)))
113   (write-char #\a s)
114   (assert (not (file-position s 1)))
115   (assert (= 0 (file-position s))))
116
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))
124       (write-char #\a s)
125       (assert (= 1 (file-position s))) ; unicode...
126       (assert (file-position s 0))))
127   (delete-file p))
128
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)
133                `(progn
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)))))
139     (unwind-protect
140          (progn
141            (with-open-file (f test :direction :output)
142              (write-line "test" f))
143            (test-mode :append)
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)
148            (test-mode :rename)
149            (test-mode :rename-and-delete))
150       (when (probe-file test)
151         (delete-file test)))))
152
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")
157                         (num-bytes 10)
158                         (bytes (if (eq type 'signed-byte)
159                                    (loop :repeat num-bytes :collect
160                                          (- (random (ash 1 size))
161                                             (ash 1 (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))
166     (dolist (byte bytes)
167       (write-byte byte foo)))
168   (unwind-protect
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))
181
182 ;;; success