source: trunk/j/src/org/armedbear/lisp/gray-streams.lisp @ 9266

Last change on this file since 9266 was 7629, checked in by asimon, 17 years ago

GRAY-WRITE-SEQUENCE: (START 0)

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