source: trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp @ 13255

Last change on this file since 13255 was 13255, checked in by Mark Evenson, 11 years ago

Enable our GRAY-STREAMS implementation to work with flexi-streams.

With this patch, flexi-streams-1.0.7 now passes its internal tests
with ABCL. NB. One must [patch TRIVIAL-GRAY-STREAMS][1] to use the
new generic for FILE-POSITION for this to work.

[1]: http://detroit.slack.net/~evenson/abcl/trivial-gray-streams-abcl-20110320a.patch

GRAY-STREAMS:STREAM-FILE-POSITION now provides a generic function
counterpart. for FILE-POSITION on a Gray stream.

Fix OPEN-STREAM-P as described in the Gray streams proposal by adding
a field to the FUNDAMENTAL-STREAM class whose which records whether
CLOSE has been called on this stream.

Fix STREAM-OUTPUT-STREAM-P and STREAM-INPUT-STREAM_P by providing
default methods on FUNDAMENTAL-INPUT-STREAM and
FUNDAMENTAL-OUTPUT-STREAM.

Renamed all symbols old-XXXX-XXXX to the more informative
ansi-XXXX-XXXX pattern.

Remove export of unused symbols STREAM-OPEN-STREAM-P, STREAM-STREAMP,
STREAM-INPUT-STREAM-P, STREAM-OUTPUT-STREAM-P,
STREAM-STREAM-ELEMENT-TYPE, and STREAM-CLOSE which should have been
removed with r12183.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 24.3 KB
Line 
1;;; gray-streams.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
4;;; $Id: gray-streams.lisp 13255 2011-03-20 20:26:04Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from:
33;;;; Gray Streams Implementation for Corman Lisp - Version 1.3
34;;;;
35;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
36;;;;
37;;;; License
38;;;; =======
39;;;; This software is provided 'as-is', without any express or implied
40;;;; warranty. In no event will the author be held liable for any damages
41;;;; arising from the use of this software.
42;;;;
43;;;; Permission is granted to anyone to use this software for any purpose,
44;;;; including commercial applications, and to alter it and redistribute
45;;;; it freely, subject to the following restrictions:
46;;;;
47;;;; 1. The origin of this software must not be misrepresented; you must
48;;;;    not claim that you wrote the original software. If you use this
49;;;;    software in a product, an acknowledgment in the product documentation
50;;;;    would be appreciated but is not required.
51;;;;
52;;;; 2. Altered source versions must be plainly marked as such, and must
53;;;;    not be misrepresented as being the original software.
54;;;;
55;;;; 3. This notice may not be removed or altered from any source
56;;;;    distribution.
57;;;;
58;;;; Notes
59;;;; =====
60;;;;
61;;;; NB: The ABCL implementation has been extensively reworked since these
62;;;; notes were included.  Please see the ABCL revision history via
63;;;; the interface at
64;;;;
65;;;; http://trac.common-lisp.net/armedbear/browser/trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp
66;;;;
67;;;; for a more relevant history vis a vis the ABCL implementation.
68;;;;
69;;;; A simple implementation of Gray streams for Corman Lisp 1.42.
70;;;; Gray streams are 'clos' based streams as described at:
71;;;;
72;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail
73;;;;
74;;;; 20110319
75;;;;   The xerox.com ftp URI doesn't resolve.  Instead see Kent Pitman's
76;;;;   archival copy at
77;;;;
78;;;;     http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html
79;;;;
80;;;; Some differences exist between this implementation and the
81;;;; specification above. See notes below for details.
82;;;;
83;;;; More recent versions of this software may be available at:
84;;;;   http://www.double.co.nz/cl
85;;;;
86;;;; Comments, suggestions and bug reports to the author,
87;;;; Christopher Double, at: chris@double.co.nz
88;;;;
89;;;; 03/03/2001 - 1.0
90;;;;              Initial release.
91;;;;
92;;;; 20/08/2001 - 1.1
93;;;;              Small modifications by Frederic Bastenaire (fba@free.fr)
94;;;;              (lines flagged by  ;; # fb 1.01)
95;;;;              - Make it work with the READ function by
96;;;;                defining %read-char, %read-char-with-error
97;;;;               and input-character-stream-p
98;;;;              - Add nickname GS to package "GRAY-STREAMS" for ease of use
99;;;;              - added missing '*' to *old-write-byte* in gray-write-byte
100;;;;
101;;;; 03/01/2002 - 1.2
102;;;;              Fixed bug with GRAY-WRITE-LINE and GRAY-WRITE-STRING
103;;;;              that appeared in Corman Lisp 2.0 due to changes to
104;;;;              WRITE-LINE and WRITE-STRING.
105;;;;
106;;;; 04/01/2002 - 1.3
107;;;;              Added support for STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE.
108;;;;              Fixed STREAM-WRITE-STRING bug.
109;;;;
110;;;; Notes
111;;;; =====
112;;;;
113;;;;
114;;;; Much of the implementation of the Gray streams below is from the
115;;;; document referenced earlier.
116;;;;
117(defpackage "GRAY-STREAMS"
118  (:use
119   "COMMON-LISP")
120  (:nicknames "GS") ;; # fb 1.01
121  (:export
122   "FUNDAMENTAL-STREAM"
123   "FUNDAMENTAL-OUTPUT-STREAM"
124   "FUNDAMENTAL-INPUT-STREAM"
125   "FUNDAMENTAL-CHARACTER-STREAM"
126   "FUNDAMENTAL-BINARY-STREAM"
127   "STREAM-READ-BYTE"
128   "STREAM-WRITE-BYTE"
129   "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
130   "STREAM-READ-CHAR"
131   "STREAM-UNREAD-CHAR"
132   "STREAM-READ-CHAR-NO-HANG"
133   "STREAM-PEEK-CHAR"
134   "STREAM-LISTEN"
135   "STREAM-READ-LINE"
136   "STREAM-CLEAR-INPUT"
137   "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
138   "STREAM-WRITE-CHAR"
139   "STREAM-LINE-COLUMN"
140   "STREAM-START-LINE-P"
141   "STREAM-WRITE-STRING"
142   "STREAM-TERPRI"
143   "STREAM-FRESH-LINE"
144   "STREAM-FINISH-OUTPUT"
145   "STREAM-FORCE-OUTPUT"
146   "STREAM-CLEAR-OUTPUT"
147   "STREAM-ADVANCE-TO-COLUMN"
148   "STREAM-READ-SEQUENCE"
149   "STREAM-WRITE-SEQUENCE"
150   "STREAM-FILE-POSITION"
151   "FUNDAMENTAL-BINARY-INPUT-STREAM"
152   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))
153
154(in-package :gray-streams)
155
156(defvar *ansi-read-char* #'read-char)
157(defvar *ansi-peek-char* #'peek-char)
158(defvar *ansi-unread-char* #'unread-char)
159(defvar *ansi-listen* nil)
160(defvar *ansi-read-line* #'read-line)
161(defvar *ansi-read-char-no-hang* #'read-char-no-hang)
162(defvar *ansi-write-char* #'write-char)
163(defvar *ansi-fresh-line* #'fresh-line)
164(defvar *ansi-terpri* #'terpri)
165(defvar *ansi-write-string* #'write-string)
166(defvar *ansi-write-line* #'write-line)
167(defvar *ansi-force-output* #'sys::%force-output)
168(defvar *ansi-finish-output* #'sys::%finish-output)
169(defvar *ansi-clear-output* #'sys::%clear-output)
170(defvar *ansi-clear-input* #'clear-input)
171(defvar *ansi-read-byte* #'read-byte)
172(defvar *ansi-write-byte* #'write-byte)
173(defvar *ansi-stream-element-type* #'cl::stream-element-type)
174(defvar *ansi-close* #'cl::close)
175(defvar *ansi-input-character-stream-p*
176  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
177(defvar *ansi-input-stream-p* #'cl::input-stream-p)
178(defvar *ansi-output-stream-p* #'cl::output-stream-p)
179(defvar *ansi-open-stream-p* #'cl::open-stream-p)
180(defvar *ansi-streamp* #'cl::streamp)
181(defvar *ansi-read-sequence* #'cl::read-sequence)
182(defvar *ansi-write-sequence* #'cl::write-sequence)
183(defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream)
184(defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
185(defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)
186(defvar *ansi-file-position* #'cl:file-position)
187
188(defun ansi-streamp (stream)
189  (or (xp::xp-structure-p stream)
190      (funcall *ansi-streamp* stream)))
191
192(defclass fundamental-stream (standard-object stream)
193  ((open-p :initform t
194           :accessor stream-open-p))
195  (:documentation "The base class of all Gray streams"))
196
197(defgeneric gray-close (stream &key abort))
198(defgeneric gray-open-stream-p (stream))
199(defgeneric gray-streamp (stream))
200(defgeneric gray-input-stream-p (stream))
201(defgeneric gray-input-character-stream-p (stream)) ;; # fb 1.01
202(defgeneric gray-output-stream-p (stream))
203(defgeneric gray-stream-element-type (stream))
204
205(defmethod gray-close ((stream fundamental-stream) &key abort)
206  (declare (ignore abort))
207  (setf (stream-open-p stream) nil)
208  t)
209
210(defmethod gray-open-stream-p ((stream fundamental-stream))
211  (stream-open-p stream))
212
213(defmethod gray-streamp ((s fundamental-stream))
214  s)
215
216(defclass fundamental-input-stream (fundamental-stream))
217
218(defmethod gray-input-character-stream-p (s)  ;; # fb 1.01
219  (and (gray-input-stream-p s)
220       (eq (gray-stream-element-type s) 'character)))
221
222(defmethod gray-input-stream-p ((s fundamental-input-stream))
223  (declare (ignore s))
224  t)
225
226(defclass fundamental-output-stream (fundamental-stream))
227
228(defmethod gray-input-stream-p ((s fundamental-output-stream))
229  (typep s 'fundamental-input-stream))
230
231(defmethod gray-output-stream-p ((s fundamental-output-stream))
232  (declare (ignore s))
233  t)
234
235(defmethod gray-output-stream-p ((s fundamental-input-stream))
236  (typep s 'fundamental-output-stream))
237
238(defclass fundamental-character-stream (fundamental-stream))
239
240(defmethod gray-stream-element-type ((s fundamental-character-stream))
241  (declare (ignore s))
242  'character)
243
244(defclass fundamental-binary-stream (fundamental-stream))
245
246(defgeneric stream-read-byte (stream))
247(defgeneric stream-write-byte (stream integer))
248
249(defclass fundamental-character-input-stream
250  (fundamental-input-stream fundamental-character-stream))
251
252(defgeneric stream-read-char (stream))
253(defgeneric stream-unread-char (stream character))
254(defgeneric stream-read-char-no-hang (stream))
255(defgeneric stream-peek-char (stream))
256(defgeneric stream-listen (stream))
257(defgeneric stream-read-line (stream))
258(defgeneric stream-clear-input (stream))
259
260(defmethod stream-peek-char ((stream fundamental-character-input-stream))
261  (let ((character (stream-read-char stream)))
262    (unless (eq character :eof)
263      (stream-unread-char stream character))
264    character))
265
266(defmethod stream-listen ((stream  fundamental-character-input-stream))
267  (let ((char (stream-read-char-no-hang stream)))
268    (and (not (null char))
269         (not (eq char :eof))
270         (progn
271           (stream-unread-char stream char)
272           t))))
273
274(defmethod stream-read-line ((stream  fundamental-character-input-stream))
275  (let ((line (make-array 64
276                          :element-type 'character
277                          :fill-pointer 0
278                          :adjustable t)))
279    (loop
280      (let ((character (stream-read-char stream)))
281        (if (eq character :eof)
282            (return (values line t))
283            (if (eql character #\Newline)
284                (return (values line nil))
285                (vector-push-extend character line)))))))
286
287(defmethod stream-clear-input (stream)
288  (declare (ignore stream))
289  nil)
290
291(defclass fundamental-character-output-stream
292  (fundamental-output-stream fundamental-character-stream))
293
294(defgeneric stream-write-char (stream character))
295(defgeneric stream-line-column (stream))
296(defgeneric stream-start-line-p (stream))
297(defgeneric stream-write-string (stream string &optional start end))
298(defgeneric stream-terpri (stream))
299(defmethod stream-terpri (stream)
300  (stream-write-char stream #\Newline))
301
302(defgeneric stream-fresh-line (stream))
303(defgeneric stream-finish-output (stream))
304(defgeneric stream-force-output (stream))
305(defgeneric stream-clear-output (stream))
306(defgeneric stream-advance-to-column (stream column))
307(defgeneric stream-read-sequence (stream sequence &optional start end))
308(defgeneric stream-write-sequence (stream sequence &optional start end))
309
310(defmethod stream-force-output (stream)
311  (declare (ignore stream))
312  nil)
313
314(defmethod stream-clear-output (stream)
315  (declare (ignore stream))
316  nil)
317
318(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
319  (equal (stream-line-column stream) 0))
320
321(defmethod stream-write-string ((stream fundamental-character-output-stream)
322                                string
323                                &optional (start 0) end)
324  (let ((end (or end (length string))))
325    (do ((i start (1+ i)))
326        ((>= i end) string)
327      (stream-write-char stream (char string i)))))
328
329(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
330  (if (stream-start-line-p stream)
331      nil
332      (progn
333        (stream-terpri stream)
334        t)))
335
336(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
337                                     column)
338  (let ((current (stream-line-column stream)))
339    (unless (null current)
340      (dotimes (i (- current column) t)
341        (stream-write-char stream #\Space)))))
342
343(defmethod stream-read-sequence ((stream  fundamental-character-input-stream)
344                                 sequence &optional (start 0) end)
345  (let ((element-type (stream-element-type stream))
346        (end (or end (length sequence)))
347        (eof (cons nil nil)))
348    (cond
349     ((eq element-type 'character)
350      (dotimes (count (- end start) (- end start))
351        (let ((c (stream-read-char stream nil eof)))
352          (if (eq c eof)
353              (return (+ count start)))
354          (setf (elt sequence (+ count start)) c))))
355     ((or (eq element-type 'byte)
356          (eq element-type 'unsigned-byte)
357          (eq element-type 'signed-byte))
358      (dotimes (count (- end start) (- end start))
359        (let ((b (stream-read-byte stream nil eof)))
360          (if (eq b eof)
361              (return (+ count start)))
362          (setf (elt sequence (+ count start)) b))))
363     (t (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A"
364               element-type)))))
365
366(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
367                                  sequence &optional (start 0) end)
368  (let ((element-type (stream-element-type stream))
369        (end (or end (length sequence))))
370    (if (eq element-type 'character)
371        (do ((n start (+ n 1)))
372            ((= n end))
373          (stream-write-char
374           stream
375           (if (typep (elt sequence n) 'number)
376               (#+nil ccl:int-char code-char (elt sequence n))
377               (elt sequence n))))
378        (do ((n start (+ n 1)))
379            ((= n end))
380          (stream-write-byte (elt sequence n) stream))))    ;; recoded to avoid LOOP, because it isn't loaded yet
381  (stream-force-output stream))
382
383(defclass fundamental-binary-input-stream
384  (fundamental-input-stream fundamental-binary-stream))
385
386(defclass fundamental-binary-output-stream
387  (fundamental-output-stream fundamental-binary-stream))
388
389(defun decode-read-arg (arg)
390  (cond ((null arg) *standard-input*)
391        ((eq arg t) *terminal-io*)
392        (t arg)))
393
394(defun decode-print-arg (arg)
395  (cond ((null arg) *standard-output*)
396        ((eq arg t) *terminal-io*)
397        (t arg)))
398
399(defun report-eof (stream eof-errorp eof-value)
400  (if eof-errorp
401      (error 'end-of-file :stream stream)
402      eof-value))
403
404(defun check-for-eof (value stream eof-errorp eof-value)
405  (if (eq value :eof)
406      (report-eof stream eof-errorp eof-value)
407      value))
408
409(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
410  (let ((stream (decode-read-arg input-stream)))
411    (if (ansi-streamp stream)
412        (funcall *ansi-read-char* stream eof-errorp eof-value recursive-p)
413        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))
414
415(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t)
416                                 eof-value recursive-p)
417  (let ((stream (decode-read-arg input-stream)))
418    (if (ansi-streamp stream)
419        (funcall *ansi-peek-char* peek-type stream eof-errorp eof-value recursive-p)
420        (if (null peek-type)
421            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
422            (loop
423              (let ((value (stream-peek-char stream)))
424                (if (eq value :eof)
425                    (return (report-eof stream eof-errorp eof-value))
426                    (if (if (eq peek-type t)
427                            (not (member value
428                                         '(#\space #\tab #\newline #\return)))
429                            (char= peek-type value))
430                        (return value)
431                        (stream-read-char stream)))))))))
432
433(defun gray-unread-char (character &optional input-stream)
434  (let ((stream (decode-read-arg input-stream)))
435    (if (ansi-streamp stream)
436        (funcall *ansi-unread-char* character stream)
437        (stream-unread-char stream character))))
438
439(defun gray-listen (&optional input-stream)
440  (let ((stream (decode-read-arg input-stream)))
441    (if (ansi-streamp stream)
442        (funcall *ansi-listen* stream)
443        (stream-listen stream))))
444
445(defun gray-read-line (&optional input-stream (eof-error-p t)
446                                 eof-value recursive-p)
447  (let ((stream (decode-read-arg input-stream)))
448    (if (ansi-streamp stream)
449        (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p)
450        (multiple-value-bind (string eofp)
451          (stream-read-line stream)
452          (if eofp
453              (if (= (length string) 0)
454                  (report-eof stream eof-error-p eof-value)
455                  (values string t))
456              (values string nil))))))
457
458(defun gray-clear-input (&optional input-stream)
459  (let ((stream (decode-read-arg input-stream)))
460    (if (ansi-streamp stream)
461        (funcall *ansi-clear-input* stream)
462        (stream-clear-input stream))))
463
464(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
465                                         eof-value recursive-p)
466  (let ((stream (decode-read-arg input-stream)))
467    (if (ansi-streamp stream)
468        (funcall *ansi-read-char-no-hang* stream eof-errorp eof-value recursive-p)
469        (check-for-eof (stream-read-char-no-hang stream)
470                       stream eof-errorp eof-value))))
471
472(defun gray-write-char (character &optional output-stream)
473  (let ((stream (decode-print-arg output-stream)))
474    (if (ansi-streamp stream)
475        (funcall *ansi-write-char* character stream)
476        (stream-write-char stream character))))
477
478(defun gray-fresh-line (&optional output-stream)
479  (let ((stream (decode-print-arg output-stream)))
480    (if (ansi-streamp stream)
481        (funcall *ansi-fresh-line* stream)
482        (stream-fresh-line stream))))
483
484(defun gray-terpri (&optional output-stream)
485  (let ((stream (decode-print-arg output-stream)))
486    (if (ansi-streamp stream)
487        (funcall *ansi-terpri* stream)
488        (stream-terpri stream))))
489
490(defun gray-write-string (string &optional output-stream &key (start 0) end)
491  (let ((stream (decode-print-arg output-stream)))
492    (if (ansi-streamp stream)
493        (funcall *ansi-write-string* string stream :start start :end end)
494        (stream-write-string stream string start end))))
495
496(defun gray-write-line (string &optional output-stream &key (start 0) end)
497  (let ((stream (decode-print-arg output-stream)))
498    (if (ansi-streamp stream)
499        (funcall *ansi-write-line* string stream :start start :end end)
500        (progn
501          (stream-write-string stream string start end)
502          (stream-terpri stream)
503          string))))
504
505(defun gray-force-output (&optional output-stream)
506  (let ((stream (decode-print-arg output-stream)))
507    (if (ansi-streamp stream)
508        (funcall *ansi-force-output* stream)
509        (stream-force-output stream))))
510
511(defun gray-finish-output (&optional output-stream)
512  (let ((stream (decode-print-arg output-stream)))
513    (if (ansi-streamp stream)
514        (funcall *ansi-finish-output* stream)
515        (stream-finish-output stream))))
516
517(defun gray-clear-output (&optional output-stream)
518  (let ((stream (decode-print-arg output-stream)))
519    (if (ansi-streamp stream)
520        (funcall *ansi-clear-output* stream)
521        (stream-clear-output stream))))
522
523(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
524  (if (ansi-streamp binary-input-stream)
525      (funcall *ansi-read-byte* binary-input-stream eof-errorp eof-value)
526      (check-for-eof (stream-read-byte binary-input-stream)
527                     binary-input-stream eof-errorp eof-value)))
528
529(defun gray-write-byte (integer binary-output-stream)
530  (if (ansi-streamp binary-output-stream)
531      (funcall *ansi-write-byte* integer binary-output-stream)
532      (stream-write-byte binary-output-stream integer)))
533
534(defmethod stream-line-column ((stream stream))
535  nil)
536
537(defun gray-stream-column (&optional input-stream)
538  (let ((stream (decode-read-arg input-stream)))
539    (if (ansi-streamp stream)
540        nil ;(funcall *ansi-stream-column* stream)
541        (stream-line-column stream))))
542
543(defmethod gray-stream-element-type (stream)
544  (funcall *ansi-stream-element-type* stream))
545
546(defmethod gray-close (stream &key abort)
547  (funcall *ansi-close* stream :abort abort))
548
549(defmethod gray-input-stream-p (stream)
550  (funcall *ansi-input-stream-p* stream))
551
552(defmethod gray-input-character-stream-p (stream)
553  (funcall *ansi-input-character-stream-p* stream))
554
555(defmethod gray-output-stream-p (stream)
556  (funcall *ansi-output-stream-p* stream))
557
558(defmethod gray-open-stream-p (stream)
559  (funcall *ansi-open-stream-p* stream))
560
561(defmethod gray-streamp (stream)
562  (funcall *ansi-streamp* stream))
563
564(defun gray-write-sequence (sequence stream &key (start 0) end)
565  (if (ansi-streamp stream)
566      (funcall *ansi-write-sequence* sequence stream :start start :end end)
567      (stream-write-sequence stream sequence start end)))
568
569(defun gray-read-sequence (sequence stream &key (start 0) end)
570  (if (ansi-streamp stream)
571      (funcall *ansi-read-sequence* sequence stream :start start :end end)
572      (stream-read-sequence stream sequence start end)))
573
574(defgeneric stream-file-position (stream &optional position-spec))
575
576(defun gray-file-position (stream &optional position-spec)
577  (if position-spec
578      (if (ansi-streamp stream)
579          (funcall *ansi-file-position* stream position-spec)
580          (stream-file-position stream position-spec))
581      (if (ansi-streamp stream)
582          (funcall *ansi-file-position* stream)
583          (stream-file-position stream))))
584 
585#|
586(defstruct (two-way-stream-g (:include stream))
587  input-stream output-stream)
588
589(defun gray-make-two-way-stream (in out)
590  (if (and (ansi-streamp in) (ansi-streamp out))
591      (funcall *ansi-make-two-way-stream* in out)
592      (make-two-way-stream-g :input-stream in :output-stream out)))
593
594(defun gray-two-way-stream-input-stream (stream)
595  (if (ansi-streamp stream)
596      (funcall *ansi-two-way-stream-input-stream* stream)
597      (two-way-stream-g-input-stream stream)))
598
599(defun gray-two-way-stream-output-stream (stream)
600  (if (ansi-streamp stream)
601      (funcall *ansi-two-way-stream-output-stream* stream)
602      (two-way-stream-g-output-stream stream)))
603
604|#
605
606(setf (symbol-function 'common-lisp::read-char) #'gray-read-char)
607(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char)
608(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char)
609(setf (symbol-function 'common-lisp::read-line) #'gray-read-line)
610(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input)
611(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang)
612(setf (symbol-function 'common-lisp::write-char) #'gray-write-char)
613(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line)
614(setf (symbol-function 'common-lisp::terpri) #'gray-terpri)
615(setf (symbol-function 'common-lisp::write-string) #'gray-write-string)
616(setf (symbol-function 'common-lisp::write-line) #'gray-write-line)
617(setf (symbol-function 'sys::%force-output) #'gray-force-output)
618(setf (symbol-function 'sys::%finish-output) #'gray-finish-output)
619(setf (symbol-function 'sys::%clear-output) #'gray-clear-output)
620(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte)
621(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte)
622(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column)
623(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type)
624(setf (symbol-function 'common-lisp::close) #'gray-close)
625(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p)
626(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p)  ;; # fb 1.01
627(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p)
628(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p)
629(setf (symbol-function 'common-lisp::streamp) #'gray-streamp)
630(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
631(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
632(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
633
634#|
635(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
636(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
637(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream)
638|#
639
640(provide 'gray-streams)
Note: See TracBrowser for help on using the repository browser.