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

  ViewVC Help
Powered by ViewVC 1.1.5