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

Last change on this file since 14207 was 14076, checked in by ehuelsmann, 8 years ago

Set function slot for CL:LISTEN when hooking up gray streams.

Patch by Stas Boukarev.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 24.8 KB
Line 
1;;; gray-streams.lisp
2;;;
3;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
4;;; $Id: gray-streams.lisp 14076 2012-08-13 06:22:13Z ehuelsmann $
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* #'listen)
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 *sys-%force-output* #'sys::%force-output)
168(defvar *sys-%finish-output* #'sys::%finish-output)
169(defvar *sys-%clear-output* #'sys::%clear-output)
170(defvar *sys-%output-object* #'sys::%output-object)
171(defvar *ansi-clear-input* #'clear-input)
172(defvar *ansi-read-byte* #'read-byte)
173(defvar *ansi-write-byte* #'write-byte)
174(defvar *ansi-stream-element-type* #'cl::stream-element-type)
175(defvar *ansi-close* #'cl::close)
176(defvar *ansi-input-character-stream-p*
177  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
178(defvar *ansi-input-stream-p* #'cl::input-stream-p)
179(defvar *ansi-output-stream-p* #'cl::output-stream-p)
180(defvar *ansi-open-stream-p* #'cl::open-stream-p)
181(defvar *ansi-streamp* #'cl::streamp)
182(defvar *ansi-read-sequence* #'cl::read-sequence)
183(defvar *ansi-write-sequence* #'cl::write-sequence)
184(defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream)
185(defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
186(defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)
187(defvar *ansi-file-position* #'cl:file-position)
188
189(defun ansi-streamp (stream)
190  (or (xp::xp-structure-p stream)
191      (funcall *ansi-streamp* stream)))
192
193(defclass fundamental-stream (standard-object stream)
194  ((open-p :initform t
195           :accessor stream-open-p))
196  (:documentation "The base class of all Gray streams"))
197
198(defgeneric gray-close (stream &key abort))
199(defgeneric gray-open-stream-p (stream))
200(defgeneric gray-streamp (stream))
201(defgeneric gray-input-stream-p (stream))
202(defgeneric gray-input-character-stream-p (stream)) ;; # fb 1.01
203(defgeneric gray-output-stream-p (stream))
204(defgeneric gray-stream-element-type (stream))
205
206(defmethod gray-close ((stream fundamental-stream) &key abort)
207  (declare (ignore abort))
208  (setf (stream-open-p stream) nil)
209  t)
210
211(defmethod gray-open-stream-p ((stream fundamental-stream))
212  (stream-open-p stream))
213
214(defmethod gray-streamp ((s fundamental-stream))
215  s)
216
217(defclass fundamental-input-stream (fundamental-stream))
218
219(defmethod gray-input-character-stream-p (s)  ;; # fb 1.01
220  (and (gray-input-stream-p s)
221       (eq (gray-stream-element-type s) 'character)))
222
223(defmethod gray-input-stream-p ((s fundamental-input-stream))
224  (declare (ignore s))
225  t)
226
227(defclass fundamental-output-stream (fundamental-stream))
228
229(defmethod gray-input-stream-p ((s fundamental-output-stream))
230  (typep s 'fundamental-input-stream))
231
232(defmethod gray-output-stream-p ((s fundamental-output-stream))
233  (declare (ignore s))
234  t)
235
236(defmethod gray-output-stream-p ((s fundamental-input-stream))
237  (typep s 'fundamental-output-stream))
238
239(defclass fundamental-character-stream (fundamental-stream))
240
241(defmethod gray-stream-element-type ((s fundamental-character-stream))
242  (declare (ignore s))
243  'character)
244
245(defclass fundamental-binary-stream (fundamental-stream))
246
247(defgeneric stream-read-byte (stream))
248(defgeneric stream-write-byte (stream integer))
249
250(defclass fundamental-character-input-stream
251  (fundamental-input-stream fundamental-character-stream))
252
253(defgeneric stream-read-char (stream))
254(defgeneric stream-unread-char (stream character))
255(defgeneric stream-read-char-no-hang (stream))
256(defgeneric stream-peek-char (stream))
257(defgeneric stream-listen (stream))
258(defgeneric stream-read-line (stream))
259(defgeneric stream-clear-input (stream))
260
261(defmethod stream-peek-char ((stream fundamental-character-input-stream))
262  (let ((character (stream-read-char stream)))
263    (unless (eq character :eof)
264      (stream-unread-char stream character))
265    character))
266
267(defmethod stream-listen ((stream  fundamental-character-input-stream))
268  (let ((char (stream-read-char-no-hang stream)))
269    (and (not (null char))
270         (not (eq char :eof))
271         (progn
272           (stream-unread-char stream char)
273           t))))
274
275(defmethod stream-read-line ((stream  fundamental-character-input-stream))
276  (let ((line (make-array 64
277                          :element-type 'character
278                          :fill-pointer 0
279                          :adjustable t)))
280    (loop
281      (let ((character (stream-read-char stream)))
282        (if (eq character :eof)
283            (return (values line t))
284            (if (eql character #\Newline)
285                (return (values line nil))
286                (vector-push-extend character line)))))))
287
288(defmethod stream-clear-input (stream)
289  (declare (ignore stream))
290  nil)
291
292(defclass fundamental-character-output-stream
293  (fundamental-output-stream fundamental-character-stream))
294
295(defgeneric stream-write-char (stream character))
296(defgeneric stream-line-column (stream))
297(defgeneric stream-start-line-p (stream))
298(defgeneric stream-write-string (stream string &optional start end))
299(defgeneric stream-terpri (stream))
300(defmethod stream-terpri (stream)
301  (stream-write-char stream #\Newline))
302
303(defgeneric stream-fresh-line (stream))
304(defgeneric stream-finish-output (stream))
305(defgeneric stream-force-output (stream))
306(defgeneric stream-clear-output (stream))
307(defgeneric stream-advance-to-column (stream column))
308(defgeneric stream-read-sequence (stream sequence &optional start end))
309(defgeneric stream-write-sequence (stream sequence &optional start end))
310
311(defmethod stream-force-output (stream)
312  (declare (ignore stream))
313  nil)
314
315(defmethod stream-clear-output (stream)
316  (declare (ignore stream))
317  nil)
318
319(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
320  (equal (stream-line-column stream) 0))
321
322(defmethod stream-write-string ((stream fundamental-character-output-stream)
323                                string
324                                &optional (start 0) end)
325  (let ((end (or end (length string))))
326    (do ((i start (1+ i)))
327        ((>= i end) string)
328      (stream-write-char stream (char string i)))))
329
330(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
331  (if (stream-start-line-p stream)
332      nil
333      (progn
334        (stream-terpri stream)
335        t)))
336
337(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
338                                     column)
339  (let ((current (stream-line-column stream)))
340    (unless (null current)
341      (dotimes (i (- current column) t)
342        (stream-write-char stream #\Space)))))
343
344(defmethod stream-read-sequence ((stream  fundamental-character-input-stream)
345                                 sequence &optional (start 0) end)
346  (let ((element-type (stream-element-type stream))
347        (end (or end (length sequence)))
348        (eof (cons nil nil)))
349    (cond
350     ((eq element-type 'character)
351      (dotimes (count (- end start) (- end start))
352        (let ((c (stream-read-char stream nil eof)))
353          (if (eq c eof)
354              (return (+ count start)))
355          (setf (elt sequence (+ count start)) c))))
356     ((or (eq element-type 'byte)
357          (eq element-type 'unsigned-byte)
358          (eq element-type 'signed-byte))
359      (dotimes (count (- end start) (- end start))
360        (let ((b (stream-read-byte stream nil eof)))
361          (if (eq b eof)
362              (return (+ count start)))
363          (setf (elt sequence (+ count start)) b))))
364     (t (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A"
365               element-type)))))
366
367(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
368                                  sequence &optional (start 0) end)
369  (let ((element-type (stream-element-type stream))
370        (end (or end (length sequence))))
371    (if (eq element-type 'character)
372        (do ((n start (+ n 1)))
373            ((= n end))
374          (stream-write-char
375           stream
376           (if (typep (elt sequence n) 'number)
377               (#+nil ccl:int-char code-char (elt sequence n))
378               (elt sequence n))))
379        (do ((n start (+ n 1)))
380            ((= n end))
381          (stream-write-byte (elt sequence n) stream))))    ;; recoded to avoid LOOP, because it isn't loaded yet
382  (stream-force-output stream))
383
384(defclass fundamental-binary-input-stream
385  (fundamental-input-stream fundamental-binary-stream))
386
387(defclass fundamental-binary-output-stream
388  (fundamental-output-stream fundamental-binary-stream))
389
390(defun decode-read-arg (arg)
391  (cond ((null arg) *standard-input*)
392        ((eq arg t) *terminal-io*)
393        (t arg)))
394
395(defun decode-print-arg (arg)
396  (cond ((null arg) *standard-output*)
397        ((eq arg t) *terminal-io*)
398        (t arg)))
399
400(defun report-eof (stream eof-errorp eof-value)
401  (if eof-errorp
402      (error 'end-of-file :stream stream)
403      eof-value))
404
405(defun check-for-eof (value stream eof-errorp eof-value)
406  (if (eq value :eof)
407      (report-eof stream eof-errorp eof-value)
408      value))
409
410(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
411  (let ((stream (decode-read-arg input-stream)))
412    (if (ansi-streamp stream)
413        (funcall *ansi-read-char* stream eof-errorp eof-value recursive-p)
414        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))
415
416(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t)
417                                 eof-value recursive-p)
418  (let ((stream (decode-read-arg input-stream)))
419    (if (ansi-streamp stream)
420        (funcall *ansi-peek-char* peek-type stream eof-errorp eof-value recursive-p)
421        (if (null peek-type)
422            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
423            (loop
424              (let ((value (stream-peek-char stream)))
425                (if (eq value :eof)
426                    (return (report-eof stream eof-errorp eof-value))
427                    (if (if (eq peek-type t)
428                            (not (member value
429                                         '(#\space #\tab #\newline #\return)))
430                            (char= peek-type value))
431                        (return value)
432                        (stream-read-char stream)))))))))
433
434(defun gray-unread-char (character &optional input-stream)
435  (let ((stream (decode-read-arg input-stream)))
436    (if (ansi-streamp stream)
437        (funcall *ansi-unread-char* character stream)
438        (stream-unread-char stream character))))
439
440(defun gray-listen (&optional input-stream)
441  (let ((stream (decode-read-arg input-stream)))
442    (if (ansi-streamp stream)
443        (funcall *ansi-listen* stream)
444        (stream-listen stream))))
445
446(defun gray-read-line (&optional input-stream (eof-error-p t)
447                                 eof-value recursive-p)
448  (let ((stream (decode-read-arg input-stream)))
449    (if (ansi-streamp stream)
450        (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p)
451        (multiple-value-bind (string eofp)
452          (stream-read-line stream)
453          (if eofp
454              (if (= (length string) 0)
455                  (report-eof stream eof-error-p eof-value)
456                  (values string t))
457              (values string nil))))))
458
459(defun gray-clear-input (&optional input-stream)
460  (let ((stream (decode-read-arg input-stream)))
461    (if (ansi-streamp stream)
462        (funcall *ansi-clear-input* stream)
463        (stream-clear-input stream))))
464
465(defun gray-output-object (object stream)
466  (if (ansi-streamp stream)
467      (funcall *sys-%output-object* object stream)
468      (stream-write-string stream 
469                           (with-output-to-string (s)
470                             (funcall *sys-%output-object* object s)))))
471
472(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
473                                         eof-value recursive-p)
474  (let ((stream (decode-read-arg input-stream)))
475    (if (ansi-streamp stream)
476        (funcall *ansi-read-char-no-hang* stream eof-errorp eof-value recursive-p)
477        (check-for-eof (stream-read-char-no-hang stream)
478                       stream eof-errorp eof-value))))
479
480(defun gray-write-char (character &optional output-stream)
481  (let ((stream (decode-print-arg output-stream)))
482    (if (ansi-streamp stream)
483        (funcall *ansi-write-char* character stream)
484        (stream-write-char stream character))))
485
486(defun gray-fresh-line (&optional output-stream)
487  (let ((stream (decode-print-arg output-stream)))
488    (if (ansi-streamp stream)
489        (funcall *ansi-fresh-line* stream)
490        (stream-fresh-line stream))))
491
492(defun gray-terpri (&optional output-stream)
493  (let ((stream (decode-print-arg output-stream)))
494    (if (ansi-streamp stream)
495        (funcall *ansi-terpri* stream)
496        (stream-terpri stream))))
497
498(defun gray-write-string (string &optional output-stream &key (start 0) end)
499  (let ((stream (decode-print-arg output-stream)))
500    (if (ansi-streamp stream)
501        (funcall *ansi-write-string* string stream :start start :end end)
502        (stream-write-string stream string start end))))
503
504(defun gray-write-line (string &optional output-stream &key (start 0) end)
505  (let ((stream (decode-print-arg output-stream)))
506    (if (ansi-streamp stream)
507        (funcall *ansi-write-line* string stream :start start :end end)
508        (progn
509          (stream-write-string stream string start end)
510          (stream-terpri stream)
511          string))))
512
513(defun gray-force-output (&optional output-stream)
514  (let ((stream (decode-print-arg output-stream)))
515    (if (ansi-streamp stream)
516        (funcall *sys-%force-output* stream)
517        (stream-force-output stream))))
518
519(defun gray-finish-output (&optional output-stream)
520  (let ((stream (decode-print-arg output-stream)))
521    (if (ansi-streamp stream)
522        (funcall *sys-%finish-output* stream)
523        (stream-finish-output stream))))
524
525(defun gray-clear-output (&optional output-stream)
526  (let ((stream (decode-print-arg output-stream)))
527    (if (ansi-streamp stream)
528        (funcall *sys-%clear-output* stream)
529        (stream-clear-output stream))))
530
531(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
532  (if (ansi-streamp binary-input-stream)
533      (funcall *ansi-read-byte* binary-input-stream eof-errorp eof-value)
534      (check-for-eof (stream-read-byte binary-input-stream)
535                     binary-input-stream eof-errorp eof-value)))
536
537(defun gray-write-byte (integer binary-output-stream)
538  (if (ansi-streamp binary-output-stream)
539      (funcall *ansi-write-byte* integer binary-output-stream)
540      (stream-write-byte binary-output-stream integer)))
541
542(defmethod stream-line-column ((stream stream))
543  nil)
544
545(defun gray-stream-column (&optional input-stream)
546  (let ((stream (decode-read-arg input-stream)))
547    (if (ansi-streamp stream)
548        nil ;(funcall *ansi-stream-column* stream)
549        (stream-line-column stream))))
550
551(defmethod gray-stream-element-type (stream)
552  (funcall *ansi-stream-element-type* stream))
553
554(defmethod gray-close (stream &key abort)
555  (funcall *ansi-close* stream :abort abort))
556
557(defmethod gray-input-stream-p (stream)
558  (funcall *ansi-input-stream-p* stream))
559
560(defmethod gray-input-character-stream-p (stream)
561  (funcall *ansi-input-character-stream-p* stream))
562
563(defmethod gray-output-stream-p (stream)
564  (funcall *ansi-output-stream-p* stream))
565
566(defmethod gray-open-stream-p (stream)
567  (funcall *ansi-open-stream-p* stream))
568
569(defmethod gray-streamp (stream)
570  (funcall *ansi-streamp* stream))
571
572(defun gray-write-sequence (sequence stream &key (start 0) end)
573  (if (ansi-streamp stream)
574      (funcall *ansi-write-sequence* sequence stream :start start :end end)
575      (stream-write-sequence stream sequence start end)))
576
577(defun gray-read-sequence (sequence stream &key (start 0) end)
578  (if (ansi-streamp stream)
579      (funcall *ansi-read-sequence* sequence stream :start start :end end)
580      (stream-read-sequence stream sequence start end)))
581
582(defgeneric stream-file-position (stream &optional position-spec))
583
584(defun gray-file-position (stream &optional position-spec)
585  (if position-spec
586      (if (ansi-streamp stream)
587          (funcall *ansi-file-position* stream position-spec)
588          (stream-file-position stream position-spec))
589      (if (ansi-streamp stream)
590          (funcall *ansi-file-position* stream)
591          (stream-file-position stream))))
592 
593#|
594(defstruct (two-way-stream-g (:include stream))
595  input-stream output-stream)
596
597(defun gray-make-two-way-stream (in out)
598  (if (and (ansi-streamp in) (ansi-streamp out))
599      (funcall *ansi-make-two-way-stream* in out)
600      (make-two-way-stream-g :input-stream in :output-stream out)))
601
602(defun gray-two-way-stream-input-stream (stream)
603  (if (ansi-streamp stream)
604      (funcall *ansi-two-way-stream-input-stream* stream)
605      (two-way-stream-g-input-stream stream)))
606
607(defun gray-two-way-stream-output-stream (stream)
608  (if (ansi-streamp stream)
609      (funcall *ansi-two-way-stream-output-stream* stream)
610      (two-way-stream-g-output-stream stream)))
611
612|#
613
614(setf (symbol-function 'common-lisp::read-char) #'gray-read-char)
615(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char)
616(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char)
617(setf (symbol-function 'common-lisp::read-line) #'gray-read-line)
618(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input)
619(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang)
620(setf (symbol-function 'common-lisp::write-char) #'gray-write-char)
621(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line)
622(setf (symbol-function 'common-lisp::terpri) #'gray-terpri)
623(setf (symbol-function 'common-lisp::write-string) #'gray-write-string)
624(setf (symbol-function 'common-lisp::write-line) #'gray-write-line)
625(setf (symbol-function 'sys::%force-output) #'gray-force-output)
626(setf (symbol-function 'sys::%finish-output) #'gray-finish-output)
627(setf (symbol-function 'sys::%clear-output) #'gray-clear-output)
628(setf (symbol-function 'sys::%output-object) #'gray-output-object)
629(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte)
630(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte)
631(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column)
632(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type)
633(setf (symbol-function 'common-lisp::close) #'gray-close)
634(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p)
635(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p)  ;; # fb 1.01
636(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p)
637(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p)
638(setf (symbol-function 'common-lisp::streamp) #'gray-streamp)
639(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
640(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
641(setf (symbol-function 'common-lisp::file-position) #'gray-file-position)
642(setf (symbol-function 'common-lisp::listen) #'gray-listen)
643#|
644(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
645(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
646(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream)
647|#
648
649(provide 'gray-streams)
Note: See TracBrowser for help on using the repository browser.