/[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.10 - (show annotations)
Sun May 4 13:11:21 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.9: +3 -3 lines
	Code cleanup.  Use EXTENSIONS package to reduce clutter.

	* src/pcl/defsys.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/pkg.lisp ("PCL", "WALKER"): Use ext.
	* src/pcl/*.lisp: Remove ext: prefixes.

	* src/pcl/low.lisp (symbolicate*): Renamed from symbolicate.
	* src/pcl/std-class.lisp (shared-initialize):
	* src/pcl/defs.lisp (get-built-in-class-symbol)
	(get-built-in-wrapper-symbol):
	* src/pcl/braid.lisp (initial-classes-and-wrappers)
	(bootstrap-meta-braid): Use symbolicate*.

	* src/pcl/macros.lisp (dolist-carefully): Removed.
	(true, false, zero): Moved to defclass.lisp.
	(printing-random-thing-internal): Removed.
	(printing-random-thing): Removed.
	(rassq): Removed.
	(*keyword-package*): Removed.
	(make-keyword): Removed; import from cl.
	(memq, delq, assq): Macros removed, import from ext.
	(get-declaration): Moved to boot.lisp, where it's used.

	* src/pcl/boot.lisp (get-declaration): Moved here from
	macros.lisp.

	* src/pcl/methods.lisp (named-object-print-function, print-object):
	* src/pcl/low.lisp (print-std-instance):
	* src/pcl/dfun.lisp (print-dfun-info):
	* src/pcl/cache.lisp (print-cache, print-wrapper):
	* src/pcl/boot.lisp (make-early-gf):
	Use print-unreadable-object instead of printing-random-thing.

	* src/pcl/defclass.lisp (true, false, zero): Moved here from
	macros.lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5