0.7.7.38:
[sbcl.git] / tests / gray-streams.impure.lisp
1 ;;;; This file is for compiler tests which have side effects (e.g.
2 ;;;; executing DEFUN) but which don't need any special side-effecting
3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
4 ;;;; settings). Similar tests which *do* expect special settings may
5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
12 ;;;; from CMU CL.
13 ;;;; 
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
17
18 (cl:in-package :cl-user)
19 \f
20 ;;;; class precedence tests
21
22 (assert (subtypep 'fundamental-stream 'stream))
23 (assert (subtypep 'fundamental-stream 'standard-object))
24
25 (assert (subtypep 'fundamental-input-stream 'fundamental-stream))
26 (assert (subtypep 'fundamental-output-stream 'fundamental-stream))
27 (assert (subtypep 'fundamental-character-stream 'fundamental-stream))
28 (assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
29
30 (assert (subtypep 'fundamental-character-input-stream
31                   'fundamental-input-stream))
32 (assert (subtypep 'fundamental-character-input-stream
33                   'fundamental-character-stream))
34 (assert (subtypep 'fundamental-character-output-stream
35                   'fundamental-output-stream))
36 (assert (subtypep 'fundamental-character-output-stream
37                   'fundamental-character-stream))
38
39 (assert (subtypep 'fundamental-binary-input-stream
40                   'fundamental-input-stream))
41 (assert (subtypep 'fundamental-binary-input-stream
42                   'fundamental-binary-stream))
43 (assert (subtypep 'fundamental-binary-output-stream
44                   'fundamental-output-stream))
45 (assert (subtypep 'fundamental-binary-output-stream
46                   'fundamental-binary-stream))
47
48 (defvar *fundamental-input-stream-instance*
49   (make-instance 'fundamental-input-stream))
50
51 (defvar *fundamental-output-stream-instance*
52   (make-instance 'fundamental-output-stream))
53
54 (defvar *fundamental-character-stream-instance*
55   (make-instance 'fundamental-character-stream))
56
57 (assert (input-stream-p *fundamental-input-stream-instance*))
58 (assert (output-stream-p *fundamental-output-stream-instance*))
59 (assert (eql (stream-element-type
60               *fundamental-character-stream-instance*)
61              'character))
62 \f
63 ;;;; example character input and output streams
64
65 (defclass character-output-stream (fundamental-character-output-stream)
66   ((lisp-stream :initarg :lisp-stream
67                 :accessor character-output-stream-lisp-stream)))
68   
69 (defclass character-input-stream (fundamental-character-input-stream)
70   ((lisp-stream :initarg :lisp-stream
71                 :accessor character-input-stream-lisp-stream)))
72 \f  
73 ;;;; example character output stream encapsulating a lisp-stream
74
75 (defun make-character-output-stream (lisp-stream)
76   (make-instance 'character-output-stream :lisp-stream lisp-stream))
77   
78 (defmethod open-stream-p ((stream character-output-stream))
79   (open-stream-p (character-output-stream-lisp-stream stream)))
80   
81 (defmethod close ((stream character-output-stream) &key abort)
82   (close (character-output-stream-lisp-stream stream) :abort abort))
83   
84 (defmethod input-stream-p ((stream character-output-stream))
85   (input-stream-p (character-output-stream-lisp-stream stream)))
86
87 (defmethod output-stream-p ((stream character-output-stream))
88   (output-stream-p (character-output-stream-lisp-stream stream)))
89
90 (defmethod stream-write-char ((stream character-output-stream) character)
91   (write-char character (character-output-stream-lisp-stream stream)))
92
93 (defmethod stream-line-column ((stream character-output-stream))
94   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
95
96 (defmethod stream-line-length ((stream character-output-stream))
97   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
98
99 (defmethod stream-finish-output ((stream character-output-stream))
100   (finish-output (character-output-stream-lisp-stream stream)))
101
102 (defmethod stream-force-output ((stream character-output-stream))
103   (force-output (character-output-stream-lisp-stream stream)))
104
105 (defmethod stream-clear-output ((stream character-output-stream))
106   (clear-output (character-output-stream-lisp-stream stream)))
107 \f
108 ;;;; example character input stream encapsulating a lisp-stream
109
110 (defun make-character-input-stream (lisp-stream)
111   (make-instance 'character-input-stream :lisp-stream lisp-stream))
112
113 (defmethod open-stream-p ((stream character-input-stream))
114   (open-stream-p (character-input-stream-lisp-stream stream)))
115
116 (defmethod close ((stream character-input-stream) &key abort)
117   (close (character-input-stream-lisp-stream stream) :abort abort))
118
119 (defmethod input-stream-p ((stream character-input-stream))
120   (input-stream-p (character-input-stream-lisp-stream stream)))
121
122 (defmethod output-stream-p ((stream character-input-stream))
123   (output-stream-p (character-input-stream-lisp-stream stream)))
124
125 (defmethod stream-read-char ((stream character-input-stream))
126   (read-char (character-input-stream-lisp-stream stream) nil :eof))
127
128 (defmethod stream-unread-char ((stream character-input-stream) character)
129   (unread-char character (character-input-stream-lisp-stream stream)))
130
131 (defmethod stream-read-char-no-hang ((stream character-input-stream))
132   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
133
134 (defmethod stream-clear-input ((stream character-input-stream))
135   (clear-input (character-input-stream-lisp-stream stream)))
136 \f
137 ;;;; tests for character i/o, using the above:
138
139 (let ((test-string (format nil
140                            "~% This is a test.~& This is the second line.~
141                              ~% This should be the third and last line.~%")))
142   (with-input-from-string (foo test-string)
143     (assert (equal
144              (with-output-to-string (bar)
145                (let ((our-char-input (make-character-input-stream foo))
146                      (our-char-output (make-character-output-stream bar)))
147                  (assert (open-stream-p our-char-input))
148                  (assert (open-stream-p our-char-output))
149                  (assert (input-stream-p our-char-input))
150                  (assert (output-stream-p our-char-output))
151                  (let ((test-char (read-char our-char-input)))
152                    (assert (char-equal test-char (char test-string 0)))
153                    (unread-char test-char our-char-input))
154                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
155                      ((not (listen our-char-input))
156                       (format our-char-output "~A~%" line))
157                    (format our-char-output "~A~%" line))
158                  (assert (null (peek-char nil our-char-input nil nil nil)))))
159              test-string))))
160
161 (assert
162   (equal
163    (with-output-to-string (foo)
164      (let ((our-char-output (make-character-output-stream foo)))
165        (write-char #\a our-char-output)
166        (finish-output our-char-output)
167        (write-char #\  our-char-output)
168        (force-output our-char-output)
169        (fresh-line our-char-output)
170        (write-char #\b our-char-output)
171        (clear-output our-char-output)
172        (terpri our-char-output)
173        (assert (null (fresh-line our-char-output)))
174        (write-char #\c our-char-output)))
175    (format nil "a ~%b~%c")))
176
177 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
178 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
179 ;;; cases. Try to verify that we don't end up doing tests like that on
180 ;;; bare Gray streams and thus bogusly omitting pretty-printing
181 ;;; operations.
182 (flet ((frob ()
183          (with-output-to-string (string)
184            (let ((gray-output-stream (make-character-output-stream string)))
185              (format gray-output-stream
186                      "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
187   (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
188   (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
189
190 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
191 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
192 ;;; where the default methods are available)
193 (let* ((test-string (format nil
194                             "~% Testing for STREAM-*-SEQUENCE.~
195                              ~& This is the second line.~
196                              ~% This should be the third and last line.~%"))
197        (test-string-len (length test-string))
198        (output-test-string (make-string test-string-len)))
199   ;; test for READ-/WRITE-SEQUENCE on strings/vectors
200   (with-input-from-string (foo test-string)
201     (assert (equal
202              (with-output-to-string (bar)
203                (let ((our-char-input (make-character-input-stream foo))
204                      (our-char-output (make-character-output-stream bar)))
205                  (read-sequence output-test-string our-char-input)
206                  (assert (typep output-test-string 'string))
207                  (write-sequence output-test-string our-char-output)
208                  (assert (null (peek-char nil our-char-input nil nil nil)))))
209              test-string)))
210   ;; test for READ-/WRITE-SEQUENCE on lists
211   (let ((output-test-list (make-list test-string-len)))
212     (with-input-from-string (foo test-string)
213       (assert (equal
214              (with-output-to-string (bar)
215                (let ((our-char-input (make-character-input-stream foo))
216                      (our-char-output (make-character-output-stream bar)))
217                  (read-sequence output-test-list our-char-input)
218                  (assert (typep output-test-list 'list))
219                  (write-sequence output-test-list our-char-output)
220                  (assert (null (peek-char nil our-char-input nil nil nil)))))
221              test-string)))))
222 \f
223 ;;;; example classes for binary output
224
225 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
226   ((lisp-stream :initarg :lisp-stream
227                 :accessor binary-to-char-output-stream-lisp-stream)))
228   
229 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
230   ((lisp-stream :initarg :lisp-stream
231                 :accessor binary-to-char-input-stream-lisp-stream)))
232
233 (defmethod stream-element-type ((stream binary-to-char-output-stream))
234   '(unsigned-byte 8))
235 (defmethod stream-element-type ((stream binary-to-char-input-stream))
236   '(unsigned-byte 8))
237
238 (defun make-binary-to-char-input-stream (lisp-stream)
239   (make-instance 'binary-to-char-input-stream
240                  :lisp-stream lisp-stream))
241
242 (defun make-binary-to-char-output-stream (lisp-stream)
243   (make-instance 'binary-to-char-output-stream
244                  :lisp-stream lisp-stream))
245   
246 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
247   (let ((char (read-char
248                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
249     (if (eq char :eof)
250         char
251         (char-code char))))
252
253 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
254   (let ((char (code-char integer)))
255     (write-char char
256                 (binary-to-char-output-stream-lisp-stream stream))))
257 \f      
258 ;;;; tests using binary i/o, using the above
259
260 (let ((test-string (format nil
261                            "~% This is a test.~& This is the second line.~
262                              ~% This should be the third and last line.~%")))
263   (with-input-from-string (foo test-string)
264     (assert (equal
265              (with-output-to-string (bar)
266                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
267                                              foo))
268                      (our-bin-to-char-output (make-binary-to-char-output-stream
269                                               bar)))
270                  (assert (open-stream-p our-bin-to-char-input))
271                  (assert (open-stream-p our-bin-to-char-output))
272                  (assert (input-stream-p our-bin-to-char-input))
273                  (assert (output-stream-p our-bin-to-char-output))
274                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
275                      ((eq byte :eof))
276                    (write-byte byte our-bin-to-char-output))))
277              test-string))))
278 \f
279 ;;;; Voila!
280
281 (quit :unix-status 104) ; success