/[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 - (hide 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 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     "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gray-streams.lisp,v 1.10 2003/05/04 13:11:21 gerd Exp $")
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    
18    
19    
20     (fmakunbound 'stream-element-type)
21    
22     (defgeneric stream-element-type (stream)
23 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 ;;;
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 dtc 1.1
105     (defgeneric stream-read-char (stream)
106 dtc 1.2 (: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 dtc 1.1
112     (defgeneric stream-unread-char (stream character)
113 dtc 1.2 (: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 dtc 1.1
118     (defgeneric stream-read-char-no-hang (stream)
119 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 t)))
154 dtc 1.1
155     (defgeneric stream-read-line (stream)
156 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (:documentation
183     "Implements CLEAR-INPUT for the stream, returning NIL. The default
184     method does nothing."))
185 dtc 1.1
186     (defmethod stream-clear-input ((stream fundamental-character-input-stream))
187     nil)
188    
189 pw 1.6 (defgeneric stream-read-sequence (stream seq &optional start end)
190 pw 1.5 (:documentation
191     "Implements READ-SEQUENCE for the stream."))
192    
193 dtc 1.1
194     ;;; Character output streams.
195 dtc 1.2 ;;;
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 dtc 1.1
200     (defgeneric stream-write-char (stream character)
201 dtc 1.2 (: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 dtc 1.1
206     (defgeneric stream-line-column (stream)
207 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
238     (defmethod stream-start-line-p ((stream fundamental-character-output-stream))
239     (eql (stream-line-column stream) 0))
240    
241 pmai 1.8 (defgeneric stream-write-string (stream string &optional start end)
242 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (:documentation
263     "Writes an end of line, as for TERPRI. Returns NIL. The default
264     method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
265 dtc 1.1
266     (defmethod stream-terpri ((stream fundamental-character-output-stream))
267     (stream-write-char stream #\Newline))
268    
269     (defgeneric stream-fresh-line (stream)
270 dtc 1.2 (: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 dtc 1.1
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 dtc 1.2 (: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 dtc 1.1
287     (defmethod stream-finish-output ((stream fundamental-output-stream))
288     nil)
289    
290     (defgeneric stream-force-output (stream)
291 dtc 1.2 (:documentation
292     "Attempts to force any buffered output to be sent. Implements
293     FORCE-OUTPUT. The default method does nothing."))
294 dtc 1.1
295     (defmethod stream-force-output ((stream fundamental-output-stream))
296     nil)
297    
298     (defgeneric stream-clear-output (stream)
299 dtc 1.2 (:documentation
300     "Clears the given output Stream. Implements CLEAR-OUTPUT. The
301     default method does nothing."))
302 dtc 1.1
303     (defmethod stream-clear-output ((stream fundamental-output-stream))
304     nil)
305    
306     (defgeneric stream-advance-to-column (stream column)
307 dtc 1.2 (: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 dtc 1.1
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 pw 1.5
324 pw 1.6 (defgeneric stream-write-sequence (stream seq &optional start end)
325 pw 1.5 (:documentation
326     "Implements WRITE-SEQUENCE for the stream."))
327 dtc 1.1
328    
329     ;;; Binary streams.
330 dtc 1.2 ;;;
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 dtc 1.1
337     (defgeneric stream-read-byte (stream)
338 dtc 1.2 (:documentation
339     "Used by READ-BYTE; returns either an integer, or the symbol :EOF
340     if the stream is at end-of-file."))
341 dtc 1.1
342     (defgeneric stream-write-byte (stream integer)
343 dtc 1.2 (:documentation
344     "Implements WRITE-BYTE; writes the integer to the stream and
345     returns the integer as the result."))
346 dtc 1.1
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 pw 1.4
422     ;; Announce ourselves to the world
423     (pushnew :gray-streams *features*)
424    
425 gerd 1.10 (setf (getf *herald-items* :gray-streams)
426 pw 1.4 '(" Gray Streams Protocol Support"))
427    

  ViewVC Help
Powered by ViewVC 1.1.5