source: branches/0.15.x/abcl/src/org/armedbear/lisp/gray-streams.lisp

;;; gray-streams.lisp
;;;
;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
;;; $Id: gray-streams.lisp 11391 2008-11-15 22:38:34Z vvoutilainen $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

;;; Adapted from:
;;;; Gray Streams Implementation for Corman Lisp - Version 1.3
;;;;
;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
;;;;
;;;; License
;;;; =======
;;;; This software is provided 'as-is', without any express or implied
;;;; warranty. In no event will the author be held liable for any damages
;;;; arising from the use of this software.
;;;;
;;;; Permission is granted to anyone to use this software for any purpose,
;;;; including commercial applications, and to alter it and redistribute
;;;; it freely, subject to the following restrictions:
;;;;
;;;; 1. The origin of this software must not be misrepresented; you must
;;;;    not claim that you wrote the original software. If you use this
;;;;    software in a product, an acknowledgment in the product documentation
;;;;    would be appreciated but is not required.
;;;;
;;;; 2. Altered source versions must be plainly marked as such, and must
;;;;    not be misrepresented as being the original software.
;;;;
;;;; 3. This notice may not be removed or altered from any source
;;;;    distribution.
;;;;
;;;; Notes
;;;; =====
;;;; A simple implementation of Gray streams for Corman Lisp 1.42.
;;;; Gray streams are 'clos' based streams as described at:
;;;;
;;;; ftp://parcftp.xerox.com/pub/cl/cleanup/mail/stream-definition-by-user.mail
;;;;
;;;; Some differences exist between this implementation and the
;;;; specification above. See notes below for details.
;;;;
;;;; More recent versions of this software may be available at:
;;;;   http://www.double.co.nz/cl
;;;;
;;;; Comments, suggestions and bug reports to the author,
;;;; Christopher Double, at: chris@double.co.nz
;;;;
;;;; 03/03/2001 - 1.0
;;;;              Initial release.
;;;;
;;;; 20/08/2001 - 1.1
;;;;              Small modifications by Frederic Bastenaire (fba@free.fr)
;;;;              (lines flagged by  ;; # fb 1.01)
;;;;              - Make it work with the READ function by
;;;;                defining %read-char, %read-char-with-error
;;;;               and input-character-stream-p
;;;;              - Add nickname GS to package "GRAY-STREAMS" for ease of use
;;;;              - added missing '*' to *old-write-byte* in gray-write-byte
;;;;
;;;; 03/01/2002 - 1.2
;;;;              Fixed bug with GRAY-WRITE-LINE and GRAY-WRITE-STRING
;;;;              that appeared in Corman Lisp 2.0 due to changes to
;;;;              WRITE-LINE and WRITE-STRING.
;;;;
;;;; 04/01/2002 - 1.3
;;;;              Added support for STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE.
;;;;              Fixed STREAM-WRITE-STRING bug.
;;;;
;;;; Notes
;;;; =====
;;;; CLOSE is not a generic function in this implementation. Instead,
;;;; the generic is called STREAM-CLOSE and the function CLOSE calls
;;;; STREAM-CLOSE. The same goes for STREAMP, INPUT-STREAM-P,
;;;; OUTPUT-STREAM-P and STREAM-ELEMENT-TYPE. The generic functions for
;;;; these are STREAM-STREAMP, STREAM-INPUT-STREAM-P,
;;;; STREAM-OUTPUT-STREAM-P and STREAM-STREAM-ELEMENT-TYPE.
;;;;
;;;; The standard Corman Lisp streams are not derived from
;;;; FUNDAMENTAL-STREAM. All the stream functions check to see if the
;;;; stream is an original Corman Lisp stream and forward on to the
;;;; original function implementations.
;;;;
;;;; The string streams are implemented in this file as Gray streams
;;;; but do not replace the Corman Lisp string streams. They are only
;;;; implemented here to test the Gray stream functionality. These methods
;;;; are called:
;;;;    GRAY-MAKE-STRING-OUTPUT-STREAM
;;;;    GRAY-GET-OUTPUT-STREAM-STRING
;;;;    GRAY-MAKE-STRING-INPUT-STREAM
;;;;
;;;; Much of the implementation of the Gray streams below is from the
;;;; document referenced earlier.
;;;;
(defpackage "GRAY-STREAMS"
  (:use
   "COMMON-LISP")
  (:nicknames "GS") ;; # fb 1.01
  (:export
   "FUNDAMENTAL-STREAM"
   "STREAM-CLOSE"
   "STREAM-OPEN-STREAM-P"
   "STREAM-STREAMP"
   "STREAM-INPUT-STREAM-P"
   "STREAM-OUTPUT-STREAM-P"
   "STREAM-STREAM-ELEMENT-TYPE"
   "STREAM-CLOSE"
   "FUNDAMENTAL-OUTPUT-STREAM"
   "FUNDAMENTAL-INPUT-STREAM"
   "FUNDAMENTAL-CHARACTER-STREAM"
   "FUNDAMENTAL-BINARY-STREAM"
   "STREAM-READ-BYTE"
   "STREAM-WRITE-BYTE"
   "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
   "STREAM-READ-CHAR"
   "STREAM-UNREAD-CHAR"
   "STREAM-READ-CHAR-NO-HANG"
   "STREAM-PEEK-CHAR"
   "STREAM-LISTEN"
   "STREAM-READ-LINE"
   "STREAM-CLEAR-INPUT"
   "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
   "STREAM-WRITE-CHAR"
   "STREAM-LINE-COLUMN"
   "STREAM-START-LINE-P"
   "STREAM-WRITE-STRING"
   "STREAM-TERPRI"
   "STREAM-FRESH-LINE"
   "STREAM-FINISH-OUTPUT"
   "STREAM-FORCE-OUTPUT"
   "STREAM-CLEAR-OUTPUT"
   "STREAM-ADVANCE-TO-COLUMN"
   "STREAM-READ-SEQUENCE"
   "STREAM-WRITE-SEQUENCE"
   "FUNDAMENTAL-BINARY-INPUT-STREAM"
   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))

(in-package :gray-streams)

(defvar *old-read-char* #'read-char)
(defvar *old-peek-char* #'peek-char)
(defvar *old-unread-char* #'unread-char)
(defvar *old-listen* nil)
(defvar *old-read-line* #'read-line)
(defvar *old-read-char-no-hang* #'read-char-no-hang)
(defvar *old-write-char* #'write-char)
(defvar *old-fresh-line* #'fresh-line)
(defvar *old-terpri* #'terpri)
(defvar *old-write-string* #'write-string)
(defvar *old-write-line* #'write-line)
(defvar *old-force-output* #'sys::%force-output)
(defvar *old-finish-output* #'sys::%finish-output)
(defvar *old-clear-output* #'sys::%clear-output)
(defvar *old-clear-input* #'clear-input)
(defvar *old-read-byte* #'read-byte)
(defvar *old-write-byte* #'write-byte)
(defvar *old-stream-element-type* #'cl::stream-element-type)
(defvar *old-close* #'cl::close)
(defvar *old-input-character-stream-p*
  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
(defvar *old-input-stream-p* #'cl::input-stream-p)
(defvar *old-output-stream-p* #'cl::output-stream-p)
(defvar *old-open-stream-p* #'cl::open-stream-p)
(defvar *old-streamp* #'cl::streamp)
(defvar *old-read-sequence* #'cl::read-sequence)
(defvar *old-write-sequence* #'cl::write-sequence)
(defvar *old-make-two-way-stream* #'cl:make-two-way-stream)
(defvar *old-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
(defvar *old-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)


(defun old-streamp (stream)
  (funcall *old-streamp* stream))

(defclass fundamental-stream ())

(defgeneric stream-close (stream &key abort))
(defgeneric stream-open-stream-p (stream))
(defgeneric stream-streamp (stream))
(defgeneric stream-input-stream-p (stream))
(defgeneric stream-input-character-stream-p (stream)) ;; # fb 1.01
(defgeneric stream-output-stream-p (stream))
(defgeneric stream-stream-element-type (stream))

(defmethod stream-close (stream &key abort)
  (declare (ignore stream abort))
  nil)

(defmethod stream-streamp (s)
  (declare (ignore s))
  nil)

(defmethod stream-streamp ((s fundamental-stream))
  s)

(defclass fundamental-input-stream (fundamental-stream))

(defmethod stream-input-character-stream-p (s)  ;; # fb 1.01
  (and (stream-input-stream-p s)
       (eq (stream-stream-element-type s) 'character)))

(defmethod stream-input-stream-p (s)
  (declare (ignore s))
  nil)

(defmethod stream-input-stream-p ((s fundamental-input-stream))
  (declare (ignore s))
  t)

(defclass fundamental-output-stream (fundamental-stream))

(defmethod stream-output-stream-p (s)
  (declare (ignore s))
  nil)

(defmethod stream-output-stream-p ((s fundamental-output-stream))
  (declare (ignore s))
  t)

(defclass fundamental-character-stream (fundamental-stream))

(defmethod stream-stream-element-type ((s fundamental-character-stream))
  (declare (ignore s))
  'character)

(defclass fundamental-binary-stream (fundamental-stream))

(defgeneric stream-read-byte (stream))
(defgeneric stream-write-byte (stream integer))

(defclass fundamental-character-input-stream
  (fundamental-input-stream fundamental-character-stream))

(defgeneric stream-read-char (stream))
(defgeneric stream-unread-char (stream character))
(defgeneric stream-read-char-no-hang (stream))
(defgeneric stream-peek-char (stream))
(defgeneric stream-listen (stream))
(defgeneric stream-read-line (stream))
(defgeneric stream-clear-input (stream))

(defmethod stream-peek-char ((stream fundamental-character-input-stream))
  (let ((character (stream-read-char stream)))
    (unless (eq character :eof)
      (stream-unread-char stream character))
    character))

(defmethod stream-listen ((stream  fundamental-character-input-stream))
  (let ((char (stream-read-char-no-hang stream)))
    (and (not (null char))
         (not (eq char :eof))
         (progn
           (stream-unread-char stream char)
           t))))

(defmethod stream-read-line ((stream  fundamental-character-input-stream))
  (let ((line (make-array 64
                          :element-type 'character
                          :fill-pointer 0
                          :adjustable t)))
    (loop
      (let ((character (stream-read-char stream)))
        (if (eq character :eof)
            (return (values line t))
            (if (eql character #\Newline)
                (return (values line nil))
                (vector-push-extend character line)))))))

(defclass fundamental-character-output-stream
  (fundamental-output-stream fundamental-character-stream))

(defgeneric stream-write-char (stream character))
(defgeneric stream-line-column (stream))
(defgeneric stream-start-line-p (stream))
(defgeneric stream-write-string (stream string &optional start end))
(defgeneric stream-terpri (stream))
(defgeneric stream-fresh-line (stream))
(defgeneric stream-finish-output (stream))
(defgeneric stream-force-output (stream))
(defgeneric stream-clear-output (stream))
(defgeneric stream-advance-to-column (stream column))
(defgeneric stream-read-sequence (stream sequence start end))
(defgeneric stream-write-sequence (stream sequence start end))

(defmethod stream-force-output (stream)
  (declare (ignore stream))
  nil)

(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
  (equal (stream-line-column stream) 0))

(defmethod stream-write-string ((stream fundamental-character-output-stream)
                                string
                                &optional
                                (start 0)
                                (end (length string)))
  (let ((start (or start 0))
        (end (or end (length string))))
    (do ((i start (1+ i)))
        ((>= i end) string)
      (stream-write-char stream (char string i)))))

(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
  (if (stream-start-line-p stream)
      nil
      (progn
        (stream-terpri stream)
        t)))

(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
                                     column)
  (let ((current (stream-line-column stream)))
    (unless (null current)
      (dotimes (i (- current column) t)
        (stream-write-char stream #\Space)))))

(defmethod stream-read-sequence ((stream  fundamental-character-input-stream) sequence start end)
  (if (null end)
      (setf end (length sequence)))
  (let ((element-type (stream-element-type stream))
        (eof (cons nil nil)))
    (cond
     ((eq element-type 'character)
      (dotimes (count (- end start) (- end start))
        (let ((c (stream-read-char stream nil eof)))
          (if (eq c eof)
              (return (+ count start)))
          (setf (elt sequence (+ count start)) c))))
     ((or (eq element-type 'byte)
          (eq element-type 'unsigned-byte)
          (eq element-type 'signed-byte))
      (dotimes (count (- end start) (- end start))
        (let ((b (stream-read-byte stream nil eof)))
          (if (eq b eof)
              (return (+ count start)))
          (setf (elt sequence (+ count start)) b))))
     (t (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A" element-type)))))

(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
                                  sequence start end)
  (let ((element-type (stream-element-type stream))
        (start (if start start 0))
        (end (if end end (length sequence))))
    (if (eq element-type 'character)
        (do ((n start (+ n 1)))
            ((= n end))
          (stream-write-char
           stream
           (if (typep (elt sequence n) 'number)
               (#+nil ccl:int-char code-char (elt sequence n))
               (elt sequence n))))
        (do ((n start (+ n 1)))
            ((= n end))
          (stream-write-byte (elt sequence n) stream))))    ;; recoded to avoid LOOP, because it isn't loaded yet
  (stream-force-output stream))

(defclass fundamental-binary-input-stream
  (fundamental-input-stream fundamental-binary-stream))

(defclass fundamental-binary-output-stream
  (fundamental-output-stream fundamental-binary-stream))

(defun decode-read-arg (arg)
  (cond ((null arg) *standard-input*)
        ((eq arg t) *terminal-io*)
        (t arg)))

(defun decode-print-arg (arg)
  (cond ((null arg) *standard-output*)
        ((eq arg t) *terminal-io*)
        (t arg)))

(defun report-eof (stream eof-errorp eof-value)
  (if eof-errorp
      (error 'end-of-file :stream stream)
      eof-value))

(defun check-for-eof (value stream eof-errorp eof-value)
  (if (eq value :eof)
      (report-eof stream eof-errorp eof-value)
      value))

(defun gray-read-char (&optional input-stream (eof-errorp t) eof-value recursive-p)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-read-char* stream eof-errorp eof-value recursive-p)
        (check-for-eof (stream-read-char stream) stream eof-errorp eof-value))))

(defun gray-peek-char (&optional peek-type input-stream (eof-errorp t)
                                 eof-value recursive-p)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-peek-char* peek-type stream eof-errorp eof-value recursive-p)
        (if (null peek-type)
            (check-for-eof (stream-peek-char stream) stream eof-errorp eof-value)
            (loop
              (let ((value (stream-peek-char stream)))
                (if (eq value :eof)
                    (return (report-eof stream eof-errorp eof-value))
                    (if (if (eq peek-type t)
                            (not (member value
                                         '(#\space #\tab #\newline #\return)))
                            (char= peek-type value))
                        (return value)
                        (stream-read-char stream)))))))))

(defun gray-unread-char (character &optional input-stream)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-unread-char* character stream)
        (stream-unread-char stream character))))

(defun gray-listen (&optional input-stream)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-listen* stream)
        (stream-listen stream))))

(defun gray-read-line (&optional input-stream (eof-error-p t)
                                 eof-value recursive-p)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-read-line* stream eof-error-p eof-value recursive-p)
        (multiple-value-bind (string eofp)
          (stream-read-line stream)
          (if eofp
              (if (= (length string) 0)
                  (report-eof stream eof-error-p eof-value)
                  (values string t))
              (values string nil))))))

(defun gray-clear-input (&optional input-stream)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-clear-input* stream)
        (stream-clear-input stream))))

(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
                                         eof-value recursive-p)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        (funcall *old-read-char-no-hang* stream eof-errorp eof-value recursive-p)
        (check-for-eof (stream-read-char-no-hang stream)
                       stream eof-errorp eof-value))))

(defun gray-write-char (character &optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-write-char* character stream)
        (stream-write-char stream character))))

(defun gray-fresh-line (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-fresh-line* stream)
        (stream-fresh-line stream))))

(defun gray-terpri (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-terpri* stream)
        (stream-terpri stream))))

(defun gray-write-string (string &optional output-stream &key (start 0) end)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-write-string* string stream :start start :end end)
        (stream-write-string stream string start end))))

(defun gray-write-line (string &optional output-stream &key (start 0) end)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-write-line* string stream :start start :end end)
        (progn
          (stream-write-string stream string start end)
          (stream-terpri stream)
          string))))

(defun gray-force-output (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-force-output* stream)
        (stream-force-output stream))))

(defun gray-finish-output (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-finish-output* stream)
        (stream-finish-output stream))))

(defun gray-clear-output (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (old-streamp stream)
        (funcall *old-clear-output* stream)
        (stream-clear-output stream))))

(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
  (if (old-streamp binary-input-stream)
      (funcall *old-read-byte* binary-input-stream eof-errorp eof-value)
      (check-for-eof (stream-read-byte binary-input-stream)
                     binary-input-stream eof-errorp eof-value)))

(defun gray-write-byte (integer binary-output-stream)
  (if (old-streamp binary-output-stream)
      (funcall *old-write-byte* integer binary-output-stream)
      (stream-write-byte binary-output-stream integer)))

(defclass string-input-stream (fundamental-character-input-stream)
  ((string :initarg :string :type string)
   (index :initarg :start :type fixnum)
   (end :initarg :end :type fixnum)))

(defun gray-make-string-input-stream (string &optional (start 0) end)
  (make-instance 'string-input-stream :string string
                 :start start :end (or end (length string))))

(defmethod stream-read-char ((stream string-input-stream))
  (with-slots (index end string) stream
    (if (>= index end)
        :eof
        (prog1
         (char string index)
         (incf index)))))

(defmethod stream-unread-char ((stream string-input-stream) character)
  (with-slots (index end string) stream
    (decf index)
    (assert (eql (char string index) character))
    nil))

(defmethod stream-read-line ((stream string-input-stream))
  (with-slots (index end string) stream
    (let* ((endline (position #\newline string :start index :end end))
           (line (subseq string index endline)))
      (if endline
          (progn
            (setq index (1+ endline))
            (values line nil))
          (progn
            (setq index end)
            (values line t))))))

(defclass string-output-stream (fundamental-character-output-stream)
  ((string :initform nil :initarg :string)))

(defun gray-make-string-output-stream ()
  (make-instance 'string-output-stream))

(defun gray-get-output-stream-string (stream)
  (with-slots (string) stream
    (if (null string)
        ""
        (prog1
         (coerce string 'string)
         (setq string nil)))))

(defmethod stream-write-char ((stream string-output-stream) character)
  (with-slots (string) stream
    (when (null string)
      (setq string (make-array 64 :slement-type 'character
                               :fill-pointer 0 :adjustable t)))
    (vector-push-extend character string)
    character))

(defmethod stream-line-column ((stream string-output-stream))
  (with-slots (string) stream
    (if (null string)
        0
        (let ((nx (position #\newline string :from-end t)))
          (if (null nx)
              (length string)
              (- (length string) nx 1))))))

(defmethod stream-line-column ((stream stream))
  nil)

(defun gray-stream-column (&optional input-stream)
  (let ((stream (decode-read-arg input-stream)))
    (if (old-streamp stream)
        nil ;(funcall *old-stream-column* stream)
        (stream-line-column stream))))

(defun gray-stream-element-type (stream)
  (if (old-streamp stream)
      (funcall *old-stream-element-type* stream)
      (stream-stream-element-type stream)))

(defun gray-close (stream &key abort)
  (if (old-streamp stream)
      (funcall *old-close* stream :abort abort)
      (stream-close stream :abort nil)))

(defun gray-input-stream-p (stream)
  (if (old-streamp stream)
      (funcall *old-input-stream-p* stream)
      (stream-input-stream-p stream)))

(defun gray-input-character-stream-p (stream)
  (if (old-streamp stream)
      (funcall *old-input-character-stream-p* stream)
      (stream-input-character-stream-p stream)))

(defun gray-output-stream-p (stream)
  (if (old-streamp stream)
      (funcall *old-output-stream-p* stream)
      (stream-output-stream-p stream)))

(defun gray-open-stream-p (stream)
  (if (old-streamp stream)
      (funcall *old-open-stream-p* stream)
      (stream-open-stream-p stream)))

(defun gray-streamp (stream)
  (if (old-streamp stream)
      (funcall *old-streamp* stream)
      (stream-streamp stream)))

(defun gray-write-sequence (sequence stream &key (start 0) end)
  (if (old-streamp stream)
      (funcall *old-write-sequence* sequence stream :start start :end end)
      (stream-write-sequence stream sequence start end)))

(defun gray-read-sequence (sequence stream &key (start 0) (end nil))
  (if (old-streamp stream)
      (funcall *old-read-sequence* sequence stream :start start :end end)
      (stream-read-sequence stream sequence start end)))

(defstruct two-way-stream-g
  input-stream output-stream)

(defun gray-make-two-way-stream (in out)
  (if (and (old-streamp in) (old-streamp out))
      (funcall *old-make-two-way-stream* in out)
      (make-two-way-stream-g :input-stream in :output-stream out)))

(defun gray-two-way-stream-input-stream (stream)
  (if (old-streamp stream)
      (funcall *old-two-way-stream-input-stream* stream)
      (two-way-stream-g-input-stream stream)))

(defun gray-two-way-stream-output-stream (stream)
  (if (old-streamp stream)
      (funcall *old-two-way-stream-output-stream* stream)
      (two-way-stream-g-output-stream stream)))

(setf (symbol-function 'common-lisp::read-char) #'gray-read-char)
(setf (symbol-function 'common-lisp::peek-char) #'gray-peek-char)
(setf (symbol-function 'common-lisp::unread-char) #'gray-unread-char)
(setf (symbol-function 'common-lisp::read-line) #'gray-read-line)
(setf (symbol-function 'common-lisp::clear-input) #'gray-clear-input)
(setf (symbol-function 'common-lisp::read-char-no-hang) #'gray-read-char-no-hang)
(setf (symbol-function 'common-lisp::write-char) #'gray-write-char)
(setf (symbol-function 'common-lisp::fresh-line) #'gray-fresh-line)
(setf (symbol-function 'common-lisp::terpri) #'gray-terpri)
(setf (symbol-function 'common-lisp::write-string) #'gray-write-string)
(setf (symbol-function 'common-lisp::write-line) #'gray-write-line)
(setf (symbol-function 'sys::%force-output) #'gray-force-output)
(setf (symbol-function 'sys::%finish-output) #'gray-finish-output)
(setf (symbol-function 'sys::%clear-output) #'gray-clear-output)
(setf (symbol-function 'common-lisp::read-byte) #'gray-read-byte)
(setf (symbol-function 'common-lisp::write-byte) #'gray-write-byte)
(setf (symbol-function 'common-lisp::stream-column) #'gray-stream-column)
(setf (symbol-function 'common-lisp::stream-element-type) #'gray-stream-element-type)
(setf (symbol-function 'common-lisp::close) #'gray-close)
(setf (symbol-function 'common-lisp::input-stream-p) #'gray-input-stream-p)
(setf (symbol-function 'common-lisp::input-character-stream-p) #'gray-input-character-stream-p)  ;; # fb 1.01
(setf (symbol-function 'common-lisp::output-stream-p) #'gray-output-stream-p)
(setf (symbol-function 'common-lisp::open-stream-p) #'gray-open-stream-p)
(setf (symbol-function 'common-lisp::streamp) #'gray-streamp)
(setf (symbol-function 'common-lisp::read-sequence) #'gray-read-sequence)
(setf (symbol-function 'common-lisp::write-sequence) #'gray-write-sequence)
(setf (symbol-function 'common-lisp::make-two-way-stream) #'gray-make-two-way-stream)
(setf (symbol-function 'common-lisp::two-way-stream-input-stream) #'gray-two-way-stream-input-stream)
(setf (symbol-function 'common-lisp::two-way-stream-output-stream) #'gray-two-way-stream-output-stream)

(provide 'gray-streams)