/[cmucl]/src/pcl/gray-streams.lisp
ViewVC logotype

Contents of /src/pcl/gray-streams.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sun Oct 28 14:38:07 2001 UTC (12 years, 5 months ago) by pw
Branch: MAIN
Changes since 1.4: +9 -1 lines
Add defgeneric forms for stream-read-sequence and stream-write-sequence.
1 ;;;
2 ;;; **********************************************************************
3 ;;; This code was written by Douglas T. Crosher and has been placed in
4 ;;; the Public domain, and is provided 'as is'.
5 ;;;
6 (ext:file-comment
7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gray-streams.lisp,v 1.5 2001/10/28 14:38:07 pw Exp $")
8 ;;;
9 ;;; **********************************************************************
10 ;;;
11 ;;; Gray streams implementation for CMUCL.
12 ;;; Based on the stream-definition-by-user proposal by David N. Gray.
13 ;;;
14
15 (in-package "LISP")
16
17
18
19 (fmakunbound 'stream-element-type)
20
21 (defgeneric stream-element-type (stream)
22 (:documentation
23 "Returns a type specifier for the kind of object returned by the
24 Stream. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method
25 which returns CHARACTER."))
26
27 (defmethod stream-element-type ((stream lisp-stream))
28 (funcall (lisp-stream-misc stream) stream :element-type))
29
30 (defmethod stream-element-type ((stream fundamental-character-stream))
31 'character)
32
33
34
35 (defgeneric pcl-open-stream-p (stream)
36 (:documentation
37 "Return true if Stream is not closed. A default method is provided
38 by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been
39 called on the stream."))
40
41 (defmethod pcl-open-stream-p ((stream lisp-stream))
42 (not (eq (lisp-stream-in stream) #'closed-flame)))
43
44 (defmethod pcl-open-stream-p ((stream fundamental-stream))
45 nil)
46
47 ;;; Bootstrapping hack.
48 (pcl-open-stream-p (make-string-output-stream))
49 (setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)
50
51
52
53
54 (defgeneric pcl-close (stream &key abort)
55 (:documentation
56 "Closes the given Stream. No more I/O may be performed, but
57 inquiries may still be made. If :Abort is non-nil, an attempt is made
58 to clean up the side effects of having created the stream."))
59
60 (defmethod pcl-close ((stream lisp-stream) &key abort)
61 (when (open-stream-p stream)
62 (funcall (lisp-stream-misc stream) stream :close abort))
63 t)
64
65 (setf (fdefinition 'close) #'pcl-close)
66
67
68
69 (fmakunbound 'input-stream-p)
70
71 (defgeneric input-stream-p (stream)
72 (:documentation "Returns non-nil if the given Stream can perform input operations."))
73
74 (defmethod input-stream-p ((stream lisp-stream))
75 (and (not (eq (lisp-stream-in stream) #'closed-flame))
76 (or (not (eq (lisp-stream-in stream) #'ill-in))
77 (not (eq (lisp-stream-bin stream) #'ill-bin)))))
78
79 (defmethod input-stream-p ((stream fundamental-input-stream))
80 t)
81
82
83
84 (fmakunbound 'output-stream-p)
85
86 (defgeneric output-stream-p (stream)
87 (:documentation "Returns non-nil if the given Stream can perform output operations."))
88
89 (defmethod output-stream-p ((stream lisp-stream))
90 (and (not (eq (lisp-stream-in stream) #'closed-flame))
91 (or (not (eq (lisp-stream-out stream) #'ill-out))
92 (not (eq (lisp-stream-bout stream) #'ill-bout)))))
93
94 (defmethod output-stream-p ((stream fundamental-output-stream))
95 t)
96
97
98 (eval-when (compile)
99 (pushnew 'compile pcl::*defgeneric-times*))
100
101 ;;; Character input streams.
102 ;;;
103 ;;; A character input stream can be created by defining a class that
104 ;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
105 ;;; for the generic functions below.
106
107 (defgeneric stream-read-char (stream)
108 (:documentation
109 "This reads one character from the stream. It returns either a
110 character object, or the symbol :EOF if the stream is at end-of-file.
111 Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
112 method for this function."))
113
114 (defgeneric stream-unread-char (stream character)
115 (:documentation
116 "Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
117 Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
118 must define a method for this function."))
119
120 (defgeneric stream-read-char-no-hang (stream)
121 (:documentation
122 "This is used to implement READ-CHAR-NO-HANG. It returns either a
123 character, or NIL if no input is currently available, or :EOF if
124 end-of-file is reached. The default method provided by
125 FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
126 is sufficient for file streams, but interactive streams should define
127 their own method."))
128
129 (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
130 (stream-read-char stream))
131
132 (defgeneric stream-peek-char (stream)
133 (:documentation
134 "Used to implement PEEK-CHAR; this corresponds to peek-type of NIL.
135 It returns either a character or :EOF. The default method calls
136 STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
137
138 (defmethod stream-peek-char ((stream fundamental-character-input-stream))
139 (let ((char (stream-read-char stream)))
140 (unless (eq char :eof)
141 (stream-unread-char stream char))
142 char))
143
144 (defgeneric stream-listen (stream)
145 (:documentation
146 "Used by LISTEN. Returns true or false. The default method uses
147 STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
148 define their own method since it will usually be trivial and will
149 always be more efficient than the default method."))
150
151 (defmethod stream-listen ((stream fundamental-character-input-stream))
152 (let ((char (stream-read-char-no-hang stream)))
153 (when (characterp char)
154 (stream-unread-char stream char)
155 t)))
156
157 (defgeneric stream-read-line (stream)
158 (:documentation
159 "Used by READ-LINE. A string is returned as the first value. The
160 second value is true if the string was terminated by end-of-file
161 instead of the end of a line. The default method uses repeated
162 calls to STREAM-READ-CHAR."))
163
164 (defmethod stream-read-line ((stream fundamental-character-input-stream))
165 (let ((res (make-string 80))
166 (len 80)
167 (index 0))
168 (loop
169 (let ((ch (stream-read-char stream)))
170 (cond ((eq ch :eof)
171 (return (values (shrink-vector res index) t)))
172 (t
173 (when (char= ch #\newline)
174 (return (values (shrink-vector res index) nil)))
175 (when (= index len)
176 (setq len (* len 2))
177 (let ((new (make-string len)))
178 (replace new res)
179 (setq res new)))
180 (setf (schar res index) ch)
181 (incf index)))))))
182
183 (defgeneric stream-clear-input (stream)
184 (:documentation
185 "Implements CLEAR-INPUT for the stream, returning NIL. The default
186 method does nothing."))
187
188 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
189 nil)
190
191 (defgeneric stream-read-sequence (seq stream &optional start end)
192 (:documentation
193 "Implements READ-SEQUENCE for the stream."))
194
195
196 ;;; Character output streams.
197 ;;;
198 ;;; A character output stream can be created by defining a class that
199 ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
200 ;;; for the generic functions below.
201
202 (defgeneric stream-write-char (stream character)
203 (:documentation
204 "Writes character to the stream and returns the character. Every
205 subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
206 defined for this function."))
207
208 (defgeneric stream-line-column (stream)
209 (:documentation
210 "This function returns the column number where the next character
211 will be written, or NIL if that is not meaningful for this stream.
212 The first column on a line is numbered 0. This function is used in
213 the implementation of PPRINT and the FORMAT ~T directive. For every
214 character output stream class that is defined, a method must be
215 defined for this function, although it is permissible for it to
216 always return NIL."))
217
218 ;;; Stream-line-length is a CMUCL extension to Gray streams.
219 (defgeneric stream-line-length (stream)
220 (:documentation "Return the stream line length or Nil."))
221
222 (defmethod stream-line-length ((stream fundamental-character-output-stream))
223 nil)
224
225 (defgeneric stream-start-line-p (stream)
226 (:documentation
227 "This is a predicate which returns T if the stream is positioned at
228 the beginning of a line, else NIL. It is permissible to always return
229 NIL. This is used in the implementation of FRESH-LINE. Note that
230 while a value of 0 from STREAM-LINE-COLUMN also indicates the
231 beginning of a line, there are cases where STREAM-START-LINE-P can be
232 meaningfully implemented although STREAM-LINE-COLUMN can't be. For
233 example, for a window using variable-width characters, the column
234 number isn't very meaningful, but the beginning of the line does have
235 a clear meaning. The default method for STREAM-START-LINE-P on class
236 FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
237 that is defined to return NIL, then a method should be provided for
238 either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
239
240 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
241 (eql (stream-line-column stream) 0))
242
243 (defgeneric stream-write-string (stream string &optional (start 0) end)
244 (:documentation
245 "This is used by WRITE-STRING. It writes the string to the stream,
246 optionally delimited by start and end, which default to 0 and NIL.
247 The string argument is returned. The default method provided by
248 FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
249 STREAM-WRITE-CHAR."))
250
251 (defmethod stream-write-string ((stream fundamental-character-output-stream)
252 string &optional (start 0) end)
253 (declare (string string)
254 (fixnum start))
255 (let ((end (or end (length string))))
256 (declare (fixnum end))
257 (do ((pos start (1+ pos)))
258 ((>= pos end))
259 (declare (type index pos))
260 (stream-write-char stream (aref string pos))))
261 string)
262
263 (defgeneric stream-terpri (stream)
264 (:documentation
265 "Writes an end of line, as for TERPRI. Returns NIL. The default
266 method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
267
268 (defmethod stream-terpri ((stream fundamental-character-output-stream))
269 (stream-write-char stream #\Newline))
270
271 (defgeneric stream-fresh-line (stream)
272 (:documentation
273 "Outputs a new line to the Stream if it is not positioned at the
274 begining of a line. Returns T if it output a new line, nil
275 otherwise. Used by FRESH-LINE. The default method uses
276 STREAM-START-LINE-P and STREAM-TERPRI."))
277
278 (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
279 (unless (stream-start-line-p stream)
280 (stream-terpri stream)
281 t))
282
283 (defgeneric stream-finish-output (stream)
284 (:documentation
285 "Attempts to ensure that all output sent to the Stream has reached
286 its destination, and only then returns false. Implements
287 FINISH-OUTPUT. The default method does nothing."))
288
289 (defmethod stream-finish-output ((stream fundamental-output-stream))
290 nil)
291
292 (defgeneric stream-force-output (stream)
293 (:documentation
294 "Attempts to force any buffered output to be sent. Implements
295 FORCE-OUTPUT. The default method does nothing."))
296
297 (defmethod stream-force-output ((stream fundamental-output-stream))
298 nil)
299
300 (defgeneric stream-clear-output (stream)
301 (:documentation
302 "Clears the given output Stream. Implements CLEAR-OUTPUT. The
303 default method does nothing."))
304
305 (defmethod stream-clear-output ((stream fundamental-output-stream))
306 nil)
307
308 (defgeneric stream-advance-to-column (stream column)
309 (:documentation
310 "Writes enough blank space so that the next character will be
311 written at the specified column. Returns true if the operation is
312 successful, or NIL if it is not supported for this stream. This is
313 intended for use by by PPRINT and FORMAT ~T. The default method uses
314 STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
315 #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
316
317 (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
318 column)
319 (let ((current-column (stream-line-column stream)))
320 (when current-column
321 (let ((fill (- column current-column)))
322 (dotimes (i fill)
323 (stream-write-char stream #\Space)))
324 T)))
325
326 (defgeneric stream-write-sequence (seq stream &optional start end)
327 (:documentation
328 "Implements WRITE-SEQUENCE for the stream."))
329
330
331 ;;; Binary streams.
332 ;;;
333 ;;; Binary streams can be created by defining a class that includes
334 ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
335 ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
336 ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
337 ;;; generic functions.
338
339 (defgeneric stream-read-byte (stream)
340 (:documentation
341 "Used by READ-BYTE; returns either an integer, or the symbol :EOF
342 if the stream is at end-of-file."))
343
344 (defgeneric stream-write-byte (stream integer)
345 (:documentation
346 "Implements WRITE-BYTE; writes the integer to the stream and
347 returns the integer as the result."))
348
349
350 ;;; Example character output stream encapsulating a lisp-stream.
351 (defun make-character-output-stream (lisp-stream)
352 (declare (type lisp-stream lisp-stream))
353 (make-instance 'character-output-stream :lisp-stream lisp-stream))
354
355 (defmethod open-stream-p ((stream character-output-stream))
356 (open-stream-p (character-output-stream-lisp-stream stream)))
357
358 (defmethod close ((stream character-output-stream) &key abort)
359 (close (character-output-stream-lisp-stream stream) :abort abort))
360
361 (defmethod input-stream-p ((stream character-output-stream))
362 (input-stream-p (character-output-stream-lisp-stream stream)))
363
364 (defmethod output-stream-p ((stream character-output-stream))
365 (output-stream-p (character-output-stream-lisp-stream stream)))
366
367 (defmethod stream-write-char ((stream character-output-stream) character)
368 (write-char character (character-output-stream-lisp-stream stream)))
369
370 (defmethod stream-line-column ((stream character-output-stream))
371 (charpos (character-output-stream-lisp-stream stream)))
372
373 (defmethod stream-line-length ((stream character-output-stream))
374 (line-length (character-output-stream-lisp-stream stream)))
375
376 (defmethod stream-finish-output ((stream character-output-stream))
377 (finish-output (character-output-stream-lisp-stream stream)))
378
379 (defmethod stream-force-output ((stream character-output-stream))
380 (force-output (character-output-stream-lisp-stream stream)))
381
382 (defmethod stream-clear-output ((stream character-output-stream))
383 (clear-output (character-output-stream-lisp-stream stream)))
384
385
386 ;;; Example character input stream encapsulating a lisp-stream.
387
388 (defun make-character-input-stream (lisp-stream)
389 (declare (type lisp-stream lisp-stream))
390 (make-instance 'character-input-stream :lisp-stream lisp-stream))
391
392 (defmethod open-stream-p ((stream character-input-stream))
393 (open-stream-p (character-input-stream-lisp-stream stream)))
394
395 (defmethod close ((stream character-input-stream) &key abort)
396 (close (character-input-stream-lisp-stream stream) :abort abort))
397
398 (defmethod input-stream-p ((stream character-input-stream))
399 (input-stream-p (character-input-stream-lisp-stream stream)))
400
401 (defmethod output-stream-p ((stream character-input-stream))
402 (output-stream-p (character-input-stream-lisp-stream stream)))
403
404 (defmethod stream-read-char ((stream character-input-stream))
405 (read-char (character-input-stream-lisp-stream stream)))
406
407 (defmethod stream-unread-char ((stream character-input-stream) character)
408 (unread-char character (character-input-stream-lisp-stream stream)))
409
410 (defmethod stream-read-char-no-hang ((stream character-input-stream))
411 (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
412
413 #+nil
414 (defmethod stream-peek-char ((stream character-input-stream))
415 (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
416
417 #+nil
418 (defmethod stream-listen ((stream character-input-stream))
419 (listen (character-input-stream-lisp-stream stream)))
420
421 (defmethod stream-clear-input ((stream character-input-stream))
422 (clear-input (character-input-stream-lisp-stream stream)))
423
424 ;; Announce ourselves to the world
425 (pushnew :gray-streams *features*)
426
427 (setf (getf ext:*herald-items* :gray-streams)
428 '(" Gray Streams Protocol Support"))
429

  ViewVC Help
Powered by ViewVC 1.1.5