/[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.7 - (hide annotations)
Tue Aug 27 19:01:39 2002 UTC (11 years, 7 months ago) by pmai
Branch: MAIN
CVS Tags: LINKAGE_TABLE, PRE_LINKAGE_TABLE, UNICODE-BASE
Branch point for: UNICODE-BRANCH
Changes since 1.6: +2 -2 lines
Patch by Gerd Moellmann to turn old-style into new-style eval-when's in
the PCL code base.
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 pmai 1.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gray-streams.lisp,v 1.7 2002/08/27 19:01:39 pmai 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 pmai 1.7 (eval-when (:compile-toplevel)
99 dtc 1.3 (pushnew 'compile pcl::*defgeneric-times*))
100    
101 dtc 1.1 ;;; Character input streams.
102 dtc 1.2 ;;;
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 dtc 1.1
107     (defgeneric stream-read-char (stream)
108 dtc 1.2 (: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 dtc 1.1
114     (defgeneric stream-unread-char (stream character)
115 dtc 1.2 (: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 dtc 1.1
120     (defgeneric stream-read-char-no-hang (stream)
121 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 t)))
156 dtc 1.1
157     (defgeneric stream-read-line (stream)
158 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (:documentation
185     "Implements CLEAR-INPUT for the stream, returning NIL. The default
186     method does nothing."))
187 dtc 1.1
188     (defmethod stream-clear-input ((stream fundamental-character-input-stream))
189     nil)
190    
191 pw 1.6 (defgeneric stream-read-sequence (stream seq &optional start end)
192 pw 1.5 (:documentation
193     "Implements READ-SEQUENCE for the stream."))
194    
195 dtc 1.1
196     ;;; Character output streams.
197 dtc 1.2 ;;;
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 dtc 1.1
202     (defgeneric stream-write-char (stream character)
203 dtc 1.2 (: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 dtc 1.1
208     (defgeneric stream-line-column (stream)
209 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (:documentation
265     "Writes an end of line, as for TERPRI. Returns NIL. The default
266     method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
267 dtc 1.1
268     (defmethod stream-terpri ((stream fundamental-character-output-stream))
269     (stream-write-char stream #\Newline))
270    
271     (defgeneric stream-fresh-line (stream)
272 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
289     (defmethod stream-finish-output ((stream fundamental-output-stream))
290     nil)
291    
292     (defgeneric stream-force-output (stream)
293 dtc 1.2 (:documentation
294     "Attempts to force any buffered output to be sent. Implements
295     FORCE-OUTPUT. The default method does nothing."))
296 dtc 1.1
297     (defmethod stream-force-output ((stream fundamental-output-stream))
298     nil)
299    
300     (defgeneric stream-clear-output (stream)
301 dtc 1.2 (:documentation
302     "Clears the given output Stream. Implements CLEAR-OUTPUT. The
303     default method does nothing."))
304 dtc 1.1
305     (defmethod stream-clear-output ((stream fundamental-output-stream))
306     nil)
307    
308     (defgeneric stream-advance-to-column (stream column)
309 dtc 1.2 (: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 dtc 1.1
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 pw 1.5
326 pw 1.6 (defgeneric stream-write-sequence (stream seq &optional start end)
327 pw 1.5 (:documentation
328     "Implements WRITE-SEQUENCE for the stream."))
329 dtc 1.1
330    
331     ;;; Binary streams.
332 dtc 1.2 ;;;
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 dtc 1.1
339     (defgeneric stream-read-byte (stream)
340 dtc 1.2 (:documentation
341     "Used by READ-BYTE; returns either an integer, or the symbol :EOF
342     if the stream is at end-of-file."))
343 dtc 1.1
344     (defgeneric stream-write-byte (stream integer)
345 dtc 1.2 (:documentation
346     "Implements WRITE-BYTE; writes the integer to the stream and
347     returns the integer as the result."))
348 dtc 1.1
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 pw 1.4
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