/[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.2.2.1 - (hide annotations)
Tue Jun 23 11:25:33 1998 UTC (15 years, 9 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18b
Changes since 1.2: +1 -1 lines
This (huge) revision brings the RELENG_18 branch up to the current HEAD.
Note code/unix-glib2.lisp not yet included -- not sure it is ready to go.
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     (ext:file-comment
7 pw 1.2.2.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gray-streams.lisp,v 1.2.2.1 1998/06/23 11:25:33 pw Exp $")
8 dtc 1.1 ;;;
9     ;;; **********************************************************************
10     ;;;
11     ;;; Gray streams implementation for CMUCL.
12 dtc 1.2 ;;; Based on the stream-definition-by-user proposal by David N. Gray.
13 dtc 1.1 ;;;
14    
15     (in-package "LISP")
16    
17    
18    
19     (fmakunbound 'stream-element-type)
20    
21     (defgeneric stream-element-type (stream)
22 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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     ;;; Character input streams.
99 dtc 1.2 ;;;
100     ;;; A character input stream can be created by defining a class that
101     ;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
102     ;;; for the generic functions below.
103 dtc 1.1
104     (defgeneric stream-read-char (stream)
105 dtc 1.2 (:documentation
106     "This reads one character from the stream. It returns either a
107     character object, or the symbol :EOF if the stream is at end-of-file.
108     Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
109     method for this function."))
110 dtc 1.1
111     (defgeneric stream-unread-char (stream character)
112 dtc 1.2 (:documentation
113     "Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
114     Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
115     must define a method for this function."))
116 dtc 1.1
117     (defgeneric stream-read-char-no-hang (stream)
118 dtc 1.2 (:documentation
119     "This is used to implement READ-CHAR-NO-HANG. It returns either a
120     character, or NIL if no input is currently available, or :EOF if
121     end-of-file is reached. The default method provided by
122     FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
123     is sufficient for file streams, but interactive streams should define
124     their own method."))
125 dtc 1.1
126     (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
127     (stream-read-char stream))
128    
129     (defgeneric stream-peek-char (stream)
130 dtc 1.2 (:documentation
131     "Used to implement PEEK-CHAR; this corresponds to peek-type of NIL.
132     It returns either a character or :EOF. The default method calls
133     STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
134 dtc 1.1
135     (defmethod stream-peek-char ((stream fundamental-character-input-stream))
136     (let ((char (stream-read-char stream)))
137     (unless (eq char :eof)
138     (stream-unread-char stream char))
139     char))
140    
141     (defgeneric stream-listen (stream)
142 dtc 1.2 (:documentation
143     "Used by LISTEN. Returns true or false. The default method uses
144     STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
145     define their own method since it will usually be trivial and will
146     always be more efficient than the default method."))
147 dtc 1.1
148     (defmethod stream-listen ((stream fundamental-character-input-stream))
149     (let ((char (stream-read-char-no-hang stream)))
150     (when (characterp char)
151     (stream-unread-char stream char)
152 dtc 1.2 t)))
153 dtc 1.1
154     (defgeneric stream-read-line (stream)
155 dtc 1.2 (:documentation
156     "Used by READ-LINE. A string is returned as the first value. The
157     second value is true if the string was terminated by end-of-file
158     instead of the end of a line. The default method uses repeated
159     calls to STREAM-READ-CHAR."))
160 dtc 1.1
161     (defmethod stream-read-line ((stream fundamental-character-input-stream))
162     (let ((res (make-string 80))
163     (len 80)
164     (index 0))
165     (loop
166     (let ((ch (stream-read-char stream)))
167     (cond ((eq ch :eof)
168     (return (values (shrink-vector res index) t)))
169     (t
170     (when (char= ch #\newline)
171     (return (values (shrink-vector res index) nil)))
172     (when (= index len)
173     (setq len (* len 2))
174     (let ((new (make-string len)))
175     (replace new res)
176     (setq res new)))
177     (setf (schar res index) ch)
178     (incf index)))))))
179    
180     (defgeneric stream-clear-input (stream)
181 dtc 1.2 (:documentation
182     "Implements CLEAR-INPUT for the stream, returning NIL. The default
183     method does nothing."))
184 dtc 1.1
185     (defmethod stream-clear-input ((stream fundamental-character-input-stream))
186     nil)
187    
188    
189     ;;; Character output streams.
190 dtc 1.2 ;;;
191     ;;; A character output stream can be created by defining a class that
192     ;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
193     ;;; for the generic functions below.
194 dtc 1.1
195     (defgeneric stream-write-char (stream character)
196 dtc 1.2 (:documentation
197     "Writes character to the stream and returns the character. Every
198     subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
199     defined for this function."))
200 dtc 1.1
201     (defgeneric stream-line-column (stream)
202 dtc 1.2 (:documentation
203     "This function returns the column number where the next character
204     will be written, or NIL if that is not meaningful for this stream.
205     The first column on a line is numbered 0. This function is used in
206     the implementation of PPRINT and the FORMAT ~T directive. For every
207     character output stream class that is defined, a method must be
208     defined for this function, although it is permissible for it to
209     always return NIL."))
210 dtc 1.1
211     ;;; Stream-line-length is a CMUCL extension to Gray streams.
212     (defgeneric stream-line-length (stream)
213     (:documentation "Return the stream line length or Nil."))
214    
215     (defmethod stream-line-length ((stream fundamental-character-output-stream))
216     nil)
217    
218     (defgeneric stream-start-line-p (stream)
219 dtc 1.2 (:documentation
220     "This is a predicate which returns T if the stream is positioned at
221     the beginning of a line, else NIL. It is permissible to always return
222     NIL. This is used in the implementation of FRESH-LINE. Note that
223     while a value of 0 from STREAM-LINE-COLUMN also indicates the
224     beginning of a line, there are cases where STREAM-START-LINE-P can be
225     meaningfully implemented although STREAM-LINE-COLUMN can't be. For
226     example, for a window using variable-width characters, the column
227     number isn't very meaningful, but the beginning of the line does have
228     a clear meaning. The default method for STREAM-START-LINE-P on class
229     FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
230     that is defined to return NIL, then a method should be provided for
231     either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
232 dtc 1.1
233     (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
234     (eql (stream-line-column stream) 0))
235    
236     (defgeneric stream-write-string (stream string &optional (start 0) end)
237 dtc 1.2 (:documentation
238     "This is used by WRITE-STRING. It writes the string to the stream,
239     optionally delimited by start and end, which default to 0 and NIL.
240     The string argument is returned. The default method provided by
241     FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
242     STREAM-WRITE-CHAR."))
243 dtc 1.1
244     (defmethod stream-write-string ((stream fundamental-character-output-stream)
245     string &optional (start 0) end)
246     (declare (string string)
247     (fixnum start))
248     (let ((end (or end (length string))))
249     (declare (fixnum end))
250     (do ((pos start (1+ pos)))
251     ((>= pos end))
252     (declare (type index pos))
253     (stream-write-char stream (aref string pos))))
254     string)
255    
256     (defgeneric stream-terpri (stream)
257 dtc 1.2 (:documentation
258     "Writes an end of line, as for TERPRI. Returns NIL. The default
259     method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
260 dtc 1.1
261     (defmethod stream-terpri ((stream fundamental-character-output-stream))
262     (stream-write-char stream #\Newline))
263    
264     (defgeneric stream-fresh-line (stream)
265 dtc 1.2 (:documentation
266     "Outputs a new line to the Stream if it is not positioned at the
267     begining of a line. Returns T if it output a new line, nil
268     otherwise. Used by FRESH-LINE. The default method uses
269     STREAM-START-LINE-P and STREAM-TERPRI."))
270 dtc 1.1
271     (defmethod stream-fresh-line ((stream fundamental-character-output-stream))
272     (unless (stream-start-line-p stream)
273     (stream-terpri stream)
274     t))
275    
276     (defgeneric stream-finish-output (stream)
277 dtc 1.2 (:documentation
278     "Attempts to ensure that all output sent to the Stream has reached
279     its destination, and only then returns false. Implements
280     FINISH-OUTPUT. The default method does nothing."))
281 dtc 1.1
282     (defmethod stream-finish-output ((stream fundamental-output-stream))
283     nil)
284    
285     (defgeneric stream-force-output (stream)
286 dtc 1.2 (:documentation
287     "Attempts to force any buffered output to be sent. Implements
288     FORCE-OUTPUT. The default method does nothing."))
289 dtc 1.1
290     (defmethod stream-force-output ((stream fundamental-output-stream))
291     nil)
292    
293     (defgeneric stream-clear-output (stream)
294 dtc 1.2 (:documentation
295     "Clears the given output Stream. Implements CLEAR-OUTPUT. The
296     default method does nothing."))
297 dtc 1.1
298     (defmethod stream-clear-output ((stream fundamental-output-stream))
299     nil)
300    
301     (defgeneric stream-advance-to-column (stream column)
302 dtc 1.2 (:documentation
303     "Writes enough blank space so that the next character will be
304     written at the specified column. Returns true if the operation is
305     successful, or NIL if it is not supported for this stream. This is
306     intended for use by by PPRINT and FORMAT ~T. The default method uses
307     STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
308     #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
309 dtc 1.1
310     (defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
311     column)
312     (let ((current-column (stream-line-column stream)))
313     (when current-column
314     (let ((fill (- column current-column)))
315     (dotimes (i fill)
316     (stream-write-char stream #\Space)))
317     T)))
318    
319    
320     ;;; Binary streams.
321 dtc 1.2 ;;;
322     ;;; Binary streams can be created by defining a class that includes
323     ;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
324     ;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
325     ;;; for STREAM-ELEMENT-TYPE and for one or both of the following
326     ;;; generic functions.
327 dtc 1.1
328     (defgeneric stream-read-byte (stream)
329 dtc 1.2 (:documentation
330     "Used by READ-BYTE; returns either an integer, or the symbol :EOF
331     if the stream is at end-of-file."))
332 dtc 1.1
333     (defgeneric stream-write-byte (stream integer)
334 dtc 1.2 (:documentation
335     "Implements WRITE-BYTE; writes the integer to the stream and
336     returns the integer as the result."))
337 dtc 1.1
338    
339     ;;; Example character output stream encapsulating a lisp-stream.
340     (defun make-character-output-stream (lisp-stream)
341     (declare (type lisp-stream lisp-stream))
342     (make-instance 'character-output-stream :lisp-stream lisp-stream))
343    
344     (defmethod open-stream-p ((stream character-output-stream))
345     (open-stream-p (character-output-stream-lisp-stream stream)))
346    
347     (defmethod close ((stream character-output-stream) &key abort)
348     (close (character-output-stream-lisp-stream stream) :abort abort))
349    
350     (defmethod input-stream-p ((stream character-output-stream))
351     (input-stream-p (character-output-stream-lisp-stream stream)))
352    
353     (defmethod output-stream-p ((stream character-output-stream))
354     (output-stream-p (character-output-stream-lisp-stream stream)))
355    
356     (defmethod stream-write-char ((stream character-output-stream) character)
357     (write-char character (character-output-stream-lisp-stream stream)))
358    
359     (defmethod stream-line-column ((stream character-output-stream))
360     (charpos (character-output-stream-lisp-stream stream)))
361    
362     (defmethod stream-line-length ((stream character-output-stream))
363     (line-length (character-output-stream-lisp-stream stream)))
364    
365     (defmethod stream-finish-output ((stream character-output-stream))
366     (finish-output (character-output-stream-lisp-stream stream)))
367    
368     (defmethod stream-force-output ((stream character-output-stream))
369     (force-output (character-output-stream-lisp-stream stream)))
370    
371     (defmethod stream-clear-output ((stream character-output-stream))
372     (clear-output (character-output-stream-lisp-stream stream)))
373    
374    
375     ;;; Example character input stream encapsulating a lisp-stream.
376    
377     (defun make-character-input-stream (lisp-stream)
378     (declare (type lisp-stream lisp-stream))
379     (make-instance 'character-input-stream :lisp-stream lisp-stream))
380    
381     (defmethod open-stream-p ((stream character-input-stream))
382     (open-stream-p (character-input-stream-lisp-stream stream)))
383    
384     (defmethod close ((stream character-input-stream) &key abort)
385     (close (character-input-stream-lisp-stream stream) :abort abort))
386    
387     (defmethod input-stream-p ((stream character-input-stream))
388     (input-stream-p (character-input-stream-lisp-stream stream)))
389    
390     (defmethod output-stream-p ((stream character-input-stream))
391     (output-stream-p (character-input-stream-lisp-stream stream)))
392    
393     (defmethod stream-read-char ((stream character-input-stream))
394     (read-char (character-input-stream-lisp-stream stream)))
395    
396     (defmethod stream-unread-char ((stream character-input-stream) character)
397     (unread-char character (character-input-stream-lisp-stream stream)))
398    
399     (defmethod stream-read-char-no-hang ((stream character-input-stream))
400     (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
401    
402     #+nil
403     (defmethod stream-peek-char ((stream character-input-stream))
404     (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
405    
406     #+nil
407     (defmethod stream-listen ((stream character-input-stream))
408     (listen (character-input-stream-lisp-stream stream)))
409    
410     (defmethod stream-clear-input ((stream character-input-stream))
411     (clear-input (character-input-stream-lisp-stream stream)))

  ViewVC Help
Powered by ViewVC 1.1.5