/[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 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years 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 ;;;
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.14 2010/03/19 15:19:03 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 (intl:textdomain "cmucl")
18
19
20
21 (fmakunbound 'stream-element-type)
22
23 (defgeneric stream-element-type (stream)
24 (:documentation
25 _N"Returns a type specifier for the kind of object returned by the
26 Stream. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method
27 which returns CHARACTER."))
28
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 (when (find-class 'stream:simple-stream nil)
36 (defmethod stream-element-type ((stream stream:simple-stream))
37 '(unsigned-byte 8)))
38
39
40
41 (defgeneric pcl-open-stream-p (stream)
42 (:documentation
43 _N"Return true if Stream is not closed. A default method is provided
44 by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been
45 called on the stream."))
46
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 (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 ;;; 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 (:documentation
65 _N"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
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 (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 (pcl-close (make-string-output-stream))
79 (setf (fdefinition 'close) #'pcl-close)
80
81
82
83 (fmakunbound 'input-stream-p)
84
85 (defgeneric input-stream-p (stream)
86 (:documentation _N"Returns non-nil if the given Stream can perform input operations."))
87
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 (not (eq (lisp-stream-bin stream) #'ill-bin))
92 (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))
93
94 (defmethod input-stream-p ((stream fundamental-input-stream))
95 t)
96
97 (when (find-class 'stream:simple-stream nil)
98 (defmethod input-stream-p ((stream stream:simple-stream))
99 (stream::%input-stream-p stream)))
100
101
102
103 (fmakunbound 'output-stream-p)
104
105 (defgeneric output-stream-p (stream)
106 (:documentation _N"Returns non-nil if the given Stream can perform output operations."))
107
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 (when (find-class 'stream:simple-stream nil)
117 (defmethod output-stream-p ((stream stream:simple-stream))
118 (stream::%output-stream-p stream)))
119
120
121 ;;; Character input streams.
122 ;;;
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
127 (defgeneric stream-read-char (stream)
128 (:documentation
129 _N"This reads one character from the stream. It returns either a
130 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
134 (defgeneric stream-unread-char (stream character)
135 (:documentation
136 _N"Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
137 Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
138 must define a method for this function."))
139
140 (defgeneric stream-read-char-no-hang (stream)
141 (:documentation
142 _N"This is used to implement READ-CHAR-NO-HANG. It returns either a
143 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
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 (:documentation
154 _N"Used to implement PEEK-CHAR; this corresponds to peek-type of NIL.
155 It returns either a character or :EOF. The default method calls
156 STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
157
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 (:documentation
166 _N"Used by LISTEN. Returns true or false. The default method uses
167 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
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 t)))
176
177 (defgeneric stream-read-line (stream)
178 (:documentation
179 _N"Used by READ-LINE. A string is returned as the first value. The
180 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
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 (:documentation
205 _N"Implements CLEAR-INPUT for the stream, returning NIL. The default
206 method does nothing."))
207
208 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
209 nil)
210
211 (defgeneric stream-read-sequence (stream seq &optional start end)
212 (:documentation
213 _N"Implements READ-SEQUENCE for the stream."))
214
215
216 ;;; Character output streams.
217 ;;;
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
222 (defgeneric stream-write-char (stream character)
223 (:documentation
224 _N"Writes character to the stream and returns the character. Every
225 subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
226 defined for this function."))
227
228 (defgeneric stream-line-column (stream)
229 (:documentation
230 _N"This function returns the column number where the next character
231 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
238 ;;; Stream-line-length is a CMUCL extension to Gray streams.
239 (defgeneric stream-line-length (stream)
240 (:documentation _N"Return the stream line length or Nil."))
241
242 (defmethod stream-line-length ((stream fundamental-character-output-stream))
243 nil)
244
245 (defgeneric stream-start-line-p (stream)
246 (:documentation
247 _N"This is a predicate which returns T if the stream is positioned at
248 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
260 (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
261 (eql (stream-line-column stream) 0))
262
263 (defgeneric stream-write-string (stream string &optional start end)
264 (:documentation
265 _N"This is used by WRITE-STRING. It writes the string to the stream,
266 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
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 (:documentation
285 _N"Writes an end of line, as for TERPRI. Returns NIL. The default
286 method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
287
288 (defmethod stream-terpri ((stream fundamental-character-output-stream))
289 (stream-write-char stream #\Newline))
290
291 (defgeneric stream-fresh-line (stream)
292 (:documentation
293 _N"Outputs a new line to the Stream if it is not positioned at the
294 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
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 (:documentation
305 _N"Attempts to ensure that all output sent to the Stream has reached
306 its destination, and only then returns false. Implements
307 FINISH-OUTPUT. The default method does nothing."))
308
309 (defmethod stream-finish-output ((stream fundamental-output-stream))
310 nil)
311
312 (defgeneric stream-force-output (stream)
313 (:documentation
314 _N"Attempts to force any buffered output to be sent. Implements
315 FORCE-OUTPUT. The default method does nothing."))
316
317 (defmethod stream-force-output ((stream fundamental-output-stream))
318 nil)
319
320 (defgeneric stream-clear-output (stream)
321 (:documentation
322 _N"Clears the given output Stream. Implements CLEAR-OUTPUT. The
323 default method does nothing."))
324
325 (defmethod stream-clear-output ((stream fundamental-output-stream))
326 nil)
327
328 (defgeneric stream-advance-to-column (stream column)
329 (:documentation
330 _N"Writes enough blank space so that the next character will be
331 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
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
346 (defgeneric stream-write-sequence (stream seq &optional start end)
347 (:documentation
348 _N"Implements WRITE-SEQUENCE for the stream."))
349
350
351 ;;; Binary streams.
352 ;;;
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
359 (defgeneric stream-read-byte (stream)
360 (:documentation
361 _N"Used by READ-BYTE; returns either an integer, or the symbol :EOF
362 if the stream is at end-of-file."))
363
364 (defgeneric stream-write-byte (stream integer)
365 (:documentation
366 _N"Implements WRITE-BYTE; writes the integer to the stream and
367 returns the integer as the result."))
368
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 #+(or)
434 (defmethod stream-peek-char ((stream character-input-stream))
435 (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
436
437 #+(or)
438 (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
444 ;; Announce ourselves to the world
445 (pushnew :gray-streams *features*)
446 (provide :gray-streams)
447
448 (setf (getf *herald-items* :gray-streams)
449 `(,#'(lambda (stream)
450 (write-string _" Gray Streams Protocol Support" stream))))
451
452
453

  ViewVC Help
Powered by ViewVC 1.1.5