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

  ViewVC Help
Powered by ViewVC 1.1.5