Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / gray-streams.impure.lisp
1 ;;;; tests related to Gray 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 (cl:in-package :cl-user)
15 \f
16 ;;;; class precedence tests
17
18 (assert (subtypep 'fundamental-stream 'stream))
19 (assert (subtypep 'fundamental-stream 'standard-object))
20
21 (assert (subtypep 'fundamental-input-stream 'fundamental-stream))
22 (assert (subtypep 'fundamental-output-stream 'fundamental-stream))
23 (assert (subtypep 'fundamental-character-stream 'fundamental-stream))
24 (assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
25
26 (assert (subtypep 'fundamental-character-input-stream
27                   'fundamental-input-stream))
28 (assert (subtypep 'fundamental-character-input-stream
29                   'fundamental-character-stream))
30 (assert (subtypep 'fundamental-character-output-stream
31                   'fundamental-output-stream))
32 (assert (subtypep 'fundamental-character-output-stream
33                   'fundamental-character-stream))
34
35 (assert (subtypep 'fundamental-binary-input-stream
36                   'fundamental-input-stream))
37 (assert (subtypep 'fundamental-binary-input-stream
38                   'fundamental-binary-stream))
39 (assert (subtypep 'fundamental-binary-output-stream
40                   'fundamental-output-stream))
41 (assert (subtypep 'fundamental-binary-output-stream
42                   'fundamental-binary-stream))
43
44 (defvar *fundamental-input-stream-instance*
45   (make-instance 'fundamental-input-stream))
46
47 (defvar *fundamental-output-stream-instance*
48   (make-instance 'fundamental-output-stream))
49
50 (defvar *fundamental-character-stream-instance*
51   (make-instance 'fundamental-character-stream))
52
53 (assert (input-stream-p *fundamental-input-stream-instance*))
54 (assert (output-stream-p *fundamental-output-stream-instance*))
55 (assert (eql (stream-element-type
56               *fundamental-character-stream-instance*)
57              'character))
58 \f
59 ;;;; example character input and output streams
60
61 (defclass character-output-stream (fundamental-character-output-stream)
62   ((lisp-stream :initarg :lisp-stream
63                 :accessor character-output-stream-lisp-stream)
64    (position :initform 42 :accessor character-output-stream-position)))
65
66 (defclass character-input-stream (fundamental-character-input-stream)
67   ((lisp-stream :initarg :lisp-stream
68                 :accessor character-input-stream-lisp-stream)))
69 \f
70 ;;;; example character output stream encapsulating a lisp-stream
71
72 (defun make-character-output-stream (lisp-stream)
73   (make-instance 'character-output-stream :lisp-stream lisp-stream))
74
75 (defmethod open-stream-p ((stream character-output-stream))
76   (open-stream-p (character-output-stream-lisp-stream stream)))
77
78 (defmethod close ((stream character-output-stream) &key abort)
79   (close (character-output-stream-lisp-stream stream) :abort abort))
80
81 (defmethod input-stream-p ((stream character-output-stream))
82   (input-stream-p (character-output-stream-lisp-stream stream)))
83
84 (defmethod output-stream-p ((stream character-output-stream))
85   (output-stream-p (character-output-stream-lisp-stream stream)))
86
87 (defmethod stream-write-char ((stream character-output-stream) character)
88   (write-char character (character-output-stream-lisp-stream stream)))
89
90 (defmethod stream-line-column ((stream character-output-stream))
91   (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
92
93 (defmethod stream-line-length ((stream character-output-stream))
94   (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
95
96 (defmethod stream-finish-output ((stream character-output-stream))
97   (finish-output (character-output-stream-lisp-stream stream)))
98
99 (defmethod stream-force-output ((stream character-output-stream))
100   (force-output (character-output-stream-lisp-stream stream)))
101
102 (defmethod stream-clear-output ((stream character-output-stream))
103   (clear-output (character-output-stream-lisp-stream stream)))
104
105 (defmethod stream-file-position ((stream character-output-stream) &optional new-value)
106   (if new-value
107       (setf (character-output-stream-position stream) new-value)
108       (character-output-stream-position stream)))
109 \f
110 ;;;; example character input stream encapsulating a lisp-stream
111
112 (defun make-character-input-stream (lisp-stream)
113   (make-instance 'character-input-stream :lisp-stream lisp-stream))
114
115 (defmethod open-stream-p ((stream character-input-stream))
116   (open-stream-p (character-input-stream-lisp-stream stream)))
117
118 (defmethod close ((stream character-input-stream) &key abort)
119   (close (character-input-stream-lisp-stream stream) :abort abort))
120
121 (defmethod input-stream-p ((stream character-input-stream))
122   (input-stream-p (character-input-stream-lisp-stream stream)))
123
124 (defmethod output-stream-p ((stream character-input-stream))
125   (output-stream-p (character-input-stream-lisp-stream stream)))
126
127 (defmethod stream-read-char ((stream character-input-stream))
128   (read-char (character-input-stream-lisp-stream stream) nil :eof))
129
130 (defmethod stream-unread-char ((stream character-input-stream) character)
131   (unread-char character (character-input-stream-lisp-stream stream)))
132
133 (defmethod stream-read-char-no-hang ((stream character-input-stream))
134   (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
135
136 (defmethod stream-clear-input ((stream character-input-stream))
137   (clear-input (character-input-stream-lisp-stream stream)))
138 \f
139 ;;;; tests for character i/o, using the above:
140
141 (let ((test-string (format nil
142                            "~% This is a test.~& This is the second line.~
143                              ~% This should be the third and last line.~%")))
144   (with-input-from-string (foo test-string)
145     (assert (equal
146              (with-output-to-string (bar)
147                (let ((our-char-input (make-character-input-stream foo))
148                      (our-char-output (make-character-output-stream bar)))
149                  (assert (open-stream-p our-char-input))
150                  (assert (open-stream-p our-char-output))
151                  (assert (input-stream-p our-char-input))
152                  (assert (output-stream-p our-char-output))
153                  (let ((test-char (read-char our-char-input)))
154                    (assert (char-equal test-char (char test-string 0)))
155                    (unread-char test-char our-char-input))
156                  (do ((line #1=(read-line our-char-input nil nil nil) #1#))
157                      ((not (listen our-char-input))
158                       (format our-char-output "~A~%" line))
159                    (format our-char-output "~A~%" line))
160                  (assert (null (peek-char nil our-char-input nil nil nil)))))
161              test-string))))
162
163 (assert
164   (equal
165    (with-output-to-string (foo)
166      (let ((our-char-output (make-character-output-stream foo)))
167        (write-char #\a our-char-output)
168        (finish-output our-char-output)
169        (write-char #\  our-char-output)
170        (force-output our-char-output)
171        (fresh-line our-char-output)
172        (write-char #\b our-char-output)
173        (clear-output our-char-output)
174        (terpri our-char-output)
175        (assert (null (fresh-line our-char-output)))
176        (write-char #\c our-char-output)))
177    (format nil "a ~%b~%c")))
178
179 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
180 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
181 ;;; cases. Try to verify that we don't end up doing tests like that on
182 ;;; bare Gray streams and thus bogusly omitting pretty-printing
183 ;;; operations.
184 (flet ((frob ()
185          (with-output-to-string (string)
186            (let ((gray-output-stream (make-character-output-stream string)))
187              (format gray-output-stream
188                      "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
189   (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
190   (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
191
192 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
193 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
194 ;;; where the default methods are available)
195 (let* ((test-string (format nil
196                             "~% Testing for STREAM-*-SEQUENCE.~
197                              ~& This is the second line.~
198                              ~% This should be the third and last line.~%"))
199        (test-string-len (length test-string))
200        (output-test-string (make-string test-string-len)))
201   ;; test for READ-/WRITE-SEQUENCE on strings/vectors
202   (with-input-from-string (foo test-string)
203     (assert (equal
204              (with-output-to-string (bar)
205                (let ((our-char-input (make-character-input-stream foo))
206                      (our-char-output (make-character-output-stream bar)))
207                  (read-sequence output-test-string our-char-input)
208                  (assert (typep output-test-string 'string))
209                  (write-sequence output-test-string our-char-output)
210                  (assert (null (peek-char nil our-char-input nil nil nil)))))
211              test-string)))
212   ;; test for READ-/WRITE-SEQUENCE on lists
213   (let ((output-test-list (make-list test-string-len)))
214     (with-input-from-string (foo test-string)
215       (assert (equal
216              (with-output-to-string (bar)
217                (let ((our-char-input (make-character-input-stream foo))
218                      (our-char-output (make-character-output-stream bar)))
219                  (read-sequence output-test-list our-char-input)
220                  (assert (typep output-test-list 'list))
221                  (write-sequence output-test-list our-char-output)
222                  (assert (null (peek-char nil our-char-input nil nil nil)))))
223              test-string)))))
224 \f
225 ;;;; example classes for binary output
226
227 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
228   ((lisp-stream :initarg :lisp-stream
229                 :accessor binary-to-char-output-stream-lisp-stream)))
230
231 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
232   ((lisp-stream :initarg :lisp-stream
233                 :accessor binary-to-char-input-stream-lisp-stream)))
234
235 (defmethod stream-element-type ((stream binary-to-char-output-stream))
236   '(unsigned-byte 8))
237 (defmethod stream-element-type ((stream binary-to-char-input-stream))
238   '(unsigned-byte 8))
239
240 (defun make-binary-to-char-input-stream (lisp-stream)
241   (make-instance 'binary-to-char-input-stream
242                  :lisp-stream lisp-stream))
243
244 (defun make-binary-to-char-output-stream (lisp-stream)
245   (make-instance 'binary-to-char-output-stream
246                  :lisp-stream lisp-stream))
247
248 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
249   (let ((char (read-char
250                (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
251     (if (eq char :eof)
252         char
253         (char-code char))))
254
255 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
256   (let ((char (code-char integer)))
257     (write-char char
258                 (binary-to-char-output-stream-lisp-stream stream))))
259 \f
260 ;;;; tests using binary i/o, using the above
261
262 (let ((test-string (format nil
263                            "~% This is a test.~& This is the second line.~
264                             ~% This should be the third and last line.~%")))
265   (with-input-from-string (foo test-string)
266     (assert (equal
267              (with-output-to-string (bar)
268                (let ((our-bin-to-char-input (make-binary-to-char-input-stream
269                                              foo))
270                      (our-bin-to-char-output (make-binary-to-char-output-stream
271                                               bar)))
272                  (assert (open-stream-p our-bin-to-char-input))
273                  (assert (open-stream-p our-bin-to-char-output))
274                  (assert (input-stream-p our-bin-to-char-input))
275                  (assert (output-stream-p our-bin-to-char-output))
276                  (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
277                      ((eq byte :eof))
278                    (write-byte byte our-bin-to-char-output))))
279              test-string))))
280
281 \f
282
283 ;;; Minimal test of file-position
284 (let ((stream (make-instance 'character-output-stream)))
285   (assert (= (file-position stream) 42))
286   (assert (file-position stream 50))
287   (assert (= (file-position stream) 50)))
288
289 ;;; Using gray streams as parts of two-way-, concatenate-, and synonym-streams.
290
291 (defvar *gray-binary-data*
292   (let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0)))
293     (dotimes (i (length vector))
294       (setf (aref vector i) (random 256)))
295     vector))
296
297 (defun vector-hop-or-eof (vector)
298   (let ((pos (fill-pointer vector)))
299     (if (< pos (array-total-size vector))
300         (prog1
301             (aref vector pos)
302           (incf (fill-pointer vector)))
303         :eof)))
304
305 (defclass part-of-composite-stream (fundamental-binary-input-stream)
306   ())
307
308 (defmethod stream-read-byte ((stream part-of-composite-stream))
309   (vector-hop-or-eof *gray-binary-data*))
310
311 (defmethod stream-element-type ((stream part-of-composite-stream))
312   '(unsigned-byte 8))
313
314 (defvar *part-of-composite* (make-instance 'part-of-composite-stream))
315
316 (defun test-composite-reads (&rest streams)
317   (dolist (stream streams)
318     (setf (fill-pointer *gray-binary-data*) 0)
319     (let ((binary-buffer (make-array 1024 :element-type '(unsigned-byte 8))))
320       (assert (eql 1024 (read-sequence binary-buffer stream)))
321       (dotimes (i 1024)
322         (unless (eql (aref *gray-binary-data* i)
323                      (aref binary-buffer i))
324           (error "wanted ~S at ~S, got ~S (~S)"
325                  (aref *gray-binary-data* i)
326                  i
327                  (aref binary-buffer i)
328                  stream))))))
329
330 (test-composite-reads
331  (make-two-way-stream *part-of-composite* *standard-output*)
332  (make-concatenated-stream *part-of-composite*)
333  (make-synonym-stream '*part-of-composite*))
334
335 ;;; Using STREAM-FILE-POSITION on an ANSI-STREAM
336 (with-output-to-string (s)
337   (assert (zerop (file-position s)))
338   (assert (zerop (stream-file-position s))))