/[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.13 - (show annotations)
Wed Feb 21 15:57:08 2007 UTC (7 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, release-19e, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, pre-merge-intl-branch, release-19e-pre1, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19e-base, intl-branch-base, unicode-utf16-base, portable-clx-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, pre-telent-clx
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, unicode-string-buffer-branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.12: +2 -1 lines
Provide :gray-streams.
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
7 (file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gray-streams.lisp,v 1.13 2007/02/21 15:57:08 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Gray streams implementation for CMUCL.
13 ;;; Based on the stream-definition-by-user proposal by David N. Gray.
14 ;;;
15
16 (in-package "LISP")
17
18
19
20 (fmakunbound 'stream-element-type)
21
22 (defgeneric stream-element-type (stream)
23 (: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
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 (when (find-class 'stream:simple-stream nil)
35 (defmethod stream-element-type ((stream stream:simple-stream))
36 '(unsigned-byte 8)))
37
38
39
40 (defgeneric pcl-open-stream-p (stream)
41 (: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
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 (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 ;;; 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 (defgeneric pcl-close (stream &key abort)
63 (:documentation
64 "Closes the given Stream. No more I/O may be performed, but
65 inquiries may still be made. If :Abort is non-nil, an attempt is made
66 to clean up the side effects of having created the stream."))
67
68 (defmethod pcl-close ((stream lisp-stream) &key abort)
69 (when (open-stream-p stream)
70 (funcall (lisp-stream-misc stream) stream :close abort))
71 t)
72
73 (when (find-class 'stream:simple-stream nil)
74 (defmethod pcl-close ((stream stream:simple-stream) &key abort)
75 (stream:device-close stream abort)))
76
77 (pcl-close (make-string-output-stream))
78 (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 (not (eq (lisp-stream-bin stream) #'ill-bin))
91 (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))
92
93 (defmethod input-stream-p ((stream fundamental-input-stream))
94 t)
95
96 (when (find-class 'stream:simple-stream nil)
97 (defmethod input-stream-p ((stream stream:simple-stream))
98 (stream::%input-stream-p stream)))
99
100
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 (when (find-class 'stream:simple-stream nil)
116 (defmethod output-stream-p ((stream stream:simple-stream))
117 (stream::%output-stream-p stream)))
118
119
120 ;;; Character input streams.
121 ;;;
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
126 (defgeneric stream-read-char (stream)
127 (: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
133 (defgeneric stream-unread-char (stream character)
134 (: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
139 (defgeneric stream-read-char-no-hang (stream)
140 (: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
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 (: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
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 (: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
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 t)))
175
176 (defgeneric stream-read-line (stream)
177 (: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
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 (:documentation
204 "Implements CLEAR-INPUT for the stream, returning NIL. The default
205 method does nothing."))
206
207 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
208 nil)
209
210 (defgeneric stream-read-sequence (stream seq &optional start end)
211 (:documentation
212 "Implements READ-SEQUENCE for the stream."))
213
214
215 ;;; Character output streams.
216 ;;;
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
221 (defgeneric stream-write-char (stream character)
222 (: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
227 (defgeneric stream-line-column (stream)
228 (: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
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 (: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
259 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
260 (eql (stream-line-column stream) 0))
261
262 (defgeneric stream-write-string (stream string &optional start end)
263 (: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
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 (:documentation
284 "Writes an end of line, as for TERPRI. Returns NIL. The default
285 method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
286
287 (defmethod stream-terpri ((stream fundamental-character-output-stream))
288 (stream-write-char stream #\Newline))
289
290 (defgeneric stream-fresh-line (stream)
291 (: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
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 (: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
308 (defmethod stream-finish-output ((stream fundamental-output-stream))
309 nil)
310
311 (defgeneric stream-force-output (stream)
312 (:documentation
313 "Attempts to force any buffered output to be sent. Implements
314 FORCE-OUTPUT. The default method does nothing."))
315
316 (defmethod stream-force-output ((stream fundamental-output-stream))
317 nil)
318
319 (defgeneric stream-clear-output (stream)
320 (:documentation
321 "Clears the given output Stream. Implements CLEAR-OUTPUT. The
322 default method does nothing."))
323
324 (defmethod stream-clear-output ((stream fundamental-output-stream))
325 nil)
326
327 (defgeneric stream-advance-to-column (stream column)
328 (: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
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
345 (defgeneric stream-write-sequence (stream seq &optional start end)
346 (:documentation
347 "Implements WRITE-SEQUENCE for the stream."))
348
349
350 ;;; Binary streams.
351 ;;;
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
358 (defgeneric stream-read-byte (stream)
359 (:documentation
360 "Used by READ-BYTE; returns either an integer, or the symbol :EOF
361 if the stream is at end-of-file."))
362
363 (defgeneric stream-write-byte (stream integer)
364 (:documentation
365 "Implements WRITE-BYTE; writes the integer to the stream and
366 returns the integer as the result."))
367
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 #+(or)
433 (defmethod stream-peek-char ((stream character-input-stream))
434 (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
435
436 #+(or)
437 (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
443 ;; Announce ourselves to the world
444 (pushnew :gray-streams *features*)
445 (provide :gray-streams)
446
447 (setf (getf *herald-items* :gray-streams)
448 '(" Gray Streams Protocol Support"))
449
450
451

  ViewVC Help
Powered by ViewVC 1.1.5