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.
7 ;;;; This software is part of the SBCL system. See the README file for
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
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.
18 (cl:in-package :cl-user)
20 ;;;; class precedence tests
22 (assert (subtypep 'fundamental-stream 'stream))
23 (assert (subtypep 'fundamental-stream 'standard-object))
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))
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))
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))
48 (defvar *fundamental-input-stream-instance*
49 (make-instance 'fundamental-input-stream))
51 (defvar *fundamental-output-stream-instance*
52 (make-instance 'fundamental-output-stream))
54 (defvar *fundamental-character-stream-instance*
55 (make-instance 'fundamental-character-stream))
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*)
63 ;;;; example character input and output streams
65 (defclass character-output-stream (fundamental-character-output-stream)
66 ((lisp-stream :initarg :lisp-stream
67 :accessor character-output-stream-lisp-stream)))
69 (defclass character-input-stream (fundamental-character-input-stream)
70 ((lisp-stream :initarg :lisp-stream
71 :accessor character-input-stream-lisp-stream)))
73 ;;;; example character output stream encapsulating a lisp-stream
75 (defun make-character-output-stream (lisp-stream)
76 (declare (type sb-kernel:lisp-stream lisp-stream))
77 (make-instance 'character-output-stream :lisp-stream lisp-stream))
79 (defmethod open-stream-p ((stream character-output-stream))
80 (open-stream-p (character-output-stream-lisp-stream stream)))
82 (defmethod close ((stream character-output-stream) &key abort)
83 (close (character-output-stream-lisp-stream stream) :abort abort))
85 (defmethod input-stream-p ((stream character-output-stream))
86 (input-stream-p (character-output-stream-lisp-stream stream)))
88 (defmethod output-stream-p ((stream character-output-stream))
89 (output-stream-p (character-output-stream-lisp-stream stream)))
91 (defmethod stream-write-char ((stream character-output-stream) character)
92 (write-char character (character-output-stream-lisp-stream stream)))
94 (defmethod stream-line-column ((stream character-output-stream))
95 (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
97 (defmethod stream-line-length ((stream character-output-stream))
98 (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
100 (defmethod stream-finish-output ((stream character-output-stream))
101 (finish-output (character-output-stream-lisp-stream stream)))
103 (defmethod stream-force-output ((stream character-output-stream))
104 (force-output (character-output-stream-lisp-stream stream)))
106 (defmethod stream-clear-output ((stream character-output-stream))
107 (clear-output (character-output-stream-lisp-stream stream)))
109 ;;;; example character input stream encapsulating a lisp-stream
111 (defun make-character-input-stream (lisp-stream)
112 (declare (type sb-kernel:lisp-stream lisp-stream))
113 (make-instance 'character-input-stream :lisp-stream lisp-stream))
115 (defmethod open-stream-p ((stream character-input-stream))
116 (open-stream-p (character-input-stream-lisp-stream stream)))
118 (defmethod close ((stream character-input-stream) &key abort)
119 (close (character-input-stream-lisp-stream stream) :abort abort))
121 (defmethod input-stream-p ((stream character-input-stream))
122 (input-stream-p (character-input-stream-lisp-stream stream)))
124 (defmethod output-stream-p ((stream character-input-stream))
125 (output-stream-p (character-input-stream-lisp-stream stream)))
127 (defmethod stream-read-char ((stream character-input-stream))
128 (read-char (character-input-stream-lisp-stream stream) nil :eof))
130 (defmethod stream-unread-char ((stream character-input-stream) character)
131 (unread-char character (character-input-stream-lisp-stream stream)))
133 (defmethod stream-read-char-no-hang ((stream character-input-stream))
134 (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
137 (defmethod stream-peek-char ((stream character-input-stream))
138 (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
141 (defmethod stream-listen ((stream character-input-stream))
142 (listen (character-input-stream-lisp-stream stream)))
144 (defmethod stream-clear-input ((stream character-input-stream))
145 (clear-input (character-input-stream-lisp-stream stream)))
147 ;;;; tests for character i/o, using the above:
149 (let ((test-string (format nil
150 "~% This is a test.~& This is the second line.~
151 ~% This should be the third and last line.~%")))
152 (with-input-from-string (foo test-string)
154 (with-output-to-string (bar)
155 (let ((our-char-input (make-character-input-stream foo))
156 (our-char-output (make-character-output-stream bar)))
157 (assert (open-stream-p our-char-input))
158 (assert (open-stream-p our-char-output))
159 (assert (input-stream-p our-char-input))
160 (assert (output-stream-p our-char-output))
161 (let ((test-char (read-char our-char-input)))
162 (assert (char-equal test-char (char test-string 0)))
163 (unread-char test-char our-char-input))
164 (do ((line #1=(read-line our-char-input nil nil nil) #1#))
165 ((not (listen our-char-input))
166 (format our-char-output "~A~%" line))
167 (format our-char-output "~A~%" line))
168 (assert (null (peek-char nil our-char-input nil nil nil)))))
171 ;;;; example classes for binary output
173 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
174 ((lisp-stream :initarg :lisp-stream
175 :accessor binary-to-char-output-stream-lisp-stream)))
177 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
178 ((lisp-stream :initarg :lisp-stream
179 :accessor binary-to-char-input-stream-lisp-stream)))
181 (defmethod stream-element-type ((stream binary-to-char-output-stream))
183 (defmethod stream-element-type ((stream binary-to-char-input-stream))
186 (defun make-binary-to-char-input-stream (lisp-stream)
187 (declare (type sb-kernel:lisp-stream lisp-stream))
188 (make-instance 'binary-to-char-input-stream
189 :lisp-stream lisp-stream))
191 (defun make-binary-to-char-output-stream (lisp-stream)
192 (declare (type sb-kernel:lisp-stream lisp-stream))
193 (make-instance 'binary-to-char-output-stream
194 :lisp-stream lisp-stream))
196 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
197 (let ((char (read-char
198 (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
203 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
204 (let ((char (code-char integer)))
206 (binary-to-char-output-stream-lisp-stream stream))))
208 ;;;; tests using binary i/o, using the above
210 (let ((test-string (format nil
211 "~% This is a test.~& This is the second line.~
212 ~% This should be the third and last line.~%")))
213 (with-input-from-string (foo test-string)
215 (with-output-to-string (bar)
216 (let ((our-bin-to-char-input (make-binary-to-char-input-stream
218 (our-bin-to-char-output (make-binary-to-char-output-stream
220 (assert (open-stream-p our-bin-to-char-input))
221 (assert (open-stream-p our-bin-to-char-output))
222 (assert (input-stream-p our-bin-to-char-input))
223 (assert (output-stream-p our-bin-to-char-output))
224 (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
226 (write-byte byte our-bin-to-char-output))))
231 (quit :unix-status 104) ; success