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

;;; gray-streams.lisp
;;;
;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
;;; $Id: gray-streams.lisp 15779 2024-01-30 07:00:31Z mevenson $
;;;
;;; 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
;;;; =====
;;;;
;;;; NB: The ABCL implementation has been extensively reworked since these
;;;; notes were included.  Please see the ABCL revision history via
;;;; the interface at
;;;;
;;;; http://trac.common-lisp.net/armedbear/browser/trunk/abcl/src/org/armedbear/lisp/gray-streams.lisp 
;;;;
;;;; for a more relevant history vis a vis the ABCL implementation.
;;;;
;;;; 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
;;;;
;;;; 20110319 
;;;;   The xerox.com ftp URI doesn't resolve.  Instead see Kent Pitman's
;;;;   archival copy at
;;;;
;;;;     http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html
;;;;
;;;; 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
;;;; =====
;;;;
;;;;
;;;; Much of the implementation of the Gray streams below is from the
;;;; document referenced earlier.
;;;;
(require "PPRINT")

(defpackage "GRAY-STREAMS"
  (:use
   "COMMON-LISP")
  (:nicknames "GS") ;; # fb 1.01
  (:export
   "FUNDAMENTAL-STREAM"
   "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-LINE-LENGTH"
   "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"
   "STREAM-FILE-POSITION"
   "STREAM-FILE-LENGTH"
   "STREAM-FILE-STRING-LENGTH"
   "STREAM-ELEMENT-TYPE"
   "FUNDAMENTAL-BINARY-INPUT-STREAM"
   "FUNDAMENTAL-BINARY-OUTPUT-STREAM"))

(in-package :gray-streams)

(defvar *ansi-read-char* #'read-char)
(defvar *ansi-peek-char* #'peek-char)
(defvar *ansi-unread-char* #'unread-char)
(defvar *ansi-listen* #'listen)
(defvar *ansi-read-line* #'read-line)
(defvar *ansi-read-char-no-hang* #'read-char-no-hang)
(defvar *ansi-write-char* #'write-char)
(defvar *ansi-fresh-line* #'fresh-line)
(defvar *ansi-terpri* #'terpri)
(defvar *ansi-write-string* #'write-string)
(defvar *ansi-write-line* #'write-line)
(defvar *sys-%force-output* #'sys::%force-output)
(defvar *sys-%finish-output* #'sys::%finish-output)
(defvar *sys-%clear-output* #'sys::%clear-output)
(defvar *sys-%output-object* #'sys::%output-object)
(defvar *ansi-clear-input* #'clear-input)
(defvar *ansi-read-byte* #'read-byte)
(defvar *ansi-write-byte* #'write-byte)
(defvar *ansi-stream-element-type* #'cl::stream-element-type)
(defvar *ansi-stream-external-format* #'cl::stream-external-format)
(defvar *ansi-close* #'cl::close)
(defvar *ansi-input-character-stream-p*
  #'(lambda (s) (and (input-stream-p s) (eql (stream-element-type s) 'character))))
(defvar *ansi-input-stream-p* #'cl::input-stream-p)
(defvar *ansi-output-stream-p* #'cl::output-stream-p)
(defvar *ansi-interactive-stream-p* #'cl::interactive-stream-p)
(defvar *ansi-open-stream-p* #'cl::open-stream-p)
(defvar *ansi-streamp* #'cl::streamp)
(defvar *ansi-read-sequence* #'cl::read-sequence)
(defvar *ansi-write-sequence* #'cl::write-sequence)
(defvar *ansi-make-two-way-stream* #'cl:make-two-way-stream)
(defvar *ansi-two-way-stream-input-stream* #'cl:two-way-stream-input-stream)
(defvar *ansi-two-way-stream-output-stream* #'cl:two-way-stream-output-stream)
(defvar *ansi-file-position* #'cl:file-position)
(defvar *ansi-file-length* #'cl:file-length)
(defvar *ansi-file-string-length* #'cl:file-string-length)
(defvar *ansi-pathname* #'cl:pathname)
(defvar *ansi-truename* #'cl:truename)

(defun ansi-streamp (stream)
  (typep stream '(or sys::system-stream xp::xp-structure)))

(defclass fundamental-stream (standard-object stream)
  ((open-p :initform t
           :accessor stream-open-p))
  (:documentation "The base class of all Gray streams"))

(defgeneric gray-close (stream &key abort))
(defgeneric gray-open-stream-p (stream))
(defgeneric gray-streamp (stream))
(defgeneric gray-input-stream-p (stream))
(defgeneric gray-input-character-stream-p (stream)) ;; # fb 1.01
(defgeneric gray-output-stream-p (stream))
(defgeneric gray-interactive-stream-p (stream))
(defgeneric gray-stream-element-type (stream))
(defgeneric (setf gray-stream-element-type) (new-value stream))
(defgeneric gray-stream-external-format (stream))
(defgeneric (setf gray-stream-external-format) (new-value stream))
(defgeneric gray-pathname (pathspec))
(defgeneric gray-truename (filespec))

(defun assert-stream (stream)
  (if (gray-streamp stream)
      t
      (error 'type-error :datum stream :expected-type 'stream)))

(defun bug-or-error (stream fun)
  (assert-stream stream)
  (error "The stream ~S has no suitable method for ~S." stream fun))

(defmethod gray-close ((stream fundamental-stream) &key abort)
  (declare (ignore abort))
  (setf (stream-open-p stream) nil)
  t)

(defmethod gray-open-stream-p ((stream fundamental-stream))
  (stream-open-p stream))

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

(defmethod gray-stream-external-format ((s fundamental-stream))
  :default)

(defmethod gray-interactive-stream-p (stream)
  (declare (ignore stream))
  nil)

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

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

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

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

(defmethod gray-input-stream-p ((s fundamental-output-stream))
  (typep s 'fundamental-input-stream))

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

(defmethod gray-output-stream-p ((s fundamental-input-stream))
  (typep s 'fundamental-output-stream))

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

(defmethod gray-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-read-char-no-hang ((stream fundamental-character-input-stream))
  (stream-read-char 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)))))))

(defmethod stream-clear-input (stream)
  (declare (ignore stream))
  nil)

(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-line-length (stream))
(defgeneric stream-write-string (stream string &optional start end))
(defgeneric stream-terpri (stream))
(defmethod stream-terpri (stream)
  (stream-write-char stream #\Newline)
  nil)

(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 &optional start end))
(defgeneric stream-write-sequence (stream sequence &optional start end))

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

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

(defmethod stream-clear-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)
  (let ((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)))))

(defun basic-read-sequence (stream sequence start end
                            expected-element-type read-fun)
  (let ((element-type (stream-element-type stream)))
    (if (subtypep element-type expected-element-type)
        (dotimes (count (- end start)
                  ;; If (< end start), skip the dotimes body but
                  ;; return start
                  (max start end))
          (let ((el (funcall read-fun stream)))
            (when (eq el :eof)
              (return (+ count start)))
            (setf (elt sequence (+ count start)) el)))
        (error "Cannot READ-SEQUENCE on stream of :ELEMENT-TYPE ~A"
               element-type))))

(defun basic-write-sequence (stream sequence start end
                             expected-element-type write-fun)
  (let ((element-type (stream-element-type stream)))
    (if (subtypep element-type expected-element-type)
        ;; Avoid LOOP because it isn't loaded yet
        (do ((n start (+ n 1)))
            ((= n end))
          (funcall write-fun stream (elt sequence n)))
        (error "Cannot WRITE-SEQUENCE on stream of :ELEMENT-TYPE ~A"
               element-type)))
  (stream-force-output stream)
  sequence)

(defmethod stream-read-sequence ((stream  fundamental-character-input-stream)
                                 sequence &optional (start 0) end)
  (basic-read-sequence stream sequence start (or end (length sequence))
                       'character #'stream-read-char))

(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
                                  sequence &optional (start 0) end)
  (basic-write-sequence stream sequence start (or end (length sequence))
                        'character #'stream-write-char))

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

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

(defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
                                 sequence &optional (start 0) end)
  (basic-read-sequence stream sequence start (or end (length sequence))
                       'signed-byte #'stream-read-byte))

(defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
                                  sequence &optional (start 0) end)
  (basic-write-sequence stream sequence start (or end (length sequence))
                        'signed-byte #'stream-write-byte))

(defmethod stream-line-length (stream)
  (declare (ignore stream))
  nil)

(defmethod stream-line-length ((stream xp::xp-structure))
  (xp::line-length 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 (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-unread-char* character stream)
        (stream-unread-char stream character))))

(defun gray-listen (&optional input-stream)
  (let ((stream (decode-read-arg input-stream)))
    (if (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-read-line* stream eof-error-p eof-value recursive-p)
        (multiple-value-bind (string eofp)
            (stream-read-line stream)
          (values (if (and eofp (zerop (length string)))
                      (report-eof stream eof-error-p eof-value)
                      string)
                  eofp)))))

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

(defun gray-output-object (object stream)
  (if (ansi-streamp stream)
      (funcall *sys-%output-object* object stream)
      (stream-write-string stream 
                           (with-output-to-string (s)
                             (funcall *sys-%output-object* object s)))))

(defun gray-read-char-no-hang (&optional input-stream (eof-errorp t)
                                         eof-value recursive-p)
  (let ((stream (decode-read-arg input-stream)))
    (if (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-write-char* character stream)
        (stream-write-char stream character))))

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

(defun gray-terpri (&optional output-stream)
  (let ((stream (decode-print-arg output-stream)))
    (if (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *ansi-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 (ansi-streamp stream)
        (funcall *sys-%force-output* stream)
        (stream-force-output stream))))

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

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

(defun gray-read-byte (binary-input-stream &optional (eof-errorp t) eof-value)
  (if (ansi-streamp binary-input-stream)
      (funcall *ansi-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 (ansi-streamp binary-output-stream)
      (funcall *ansi-write-byte* integer binary-output-stream)
      (stream-write-byte binary-output-stream integer)))

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

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

(defun gray-line-length (stream)
  (max 0
       (or *print-right-margin*
           (stream-line-length stream)
           xp::*default-right-margin*
           80)))

(defmethod gray-stream-element-type (stream)
  (if (ansi-streamp stream)
      (funcall *ansi-stream-element-type* stream)
      (bug-or-error stream 'gray-stream-element-type)))

(defmethod gray-stream-external-format (stream)
  (if (ansi-streamp stream)
      (funcall *ansi-stream-external-format* stream)
      (bug-or-error stream 'gray-stream-external-format)))

(defmethod (setf gray-stream-external-format) (new-value stream)
  (if (ansi-streamp stream)
      (sys::%set-stream-external-format stream new-value)
      (bug-or-error stream 'gray-stream-external-format)))

(defmethod gray-close (stream &key abort)
  (if (ansi-streamp stream)
      (funcall *ansi-close* stream :abort abort)
      (bug-or-error stream 'gray-close)))

(defmethod gray-input-stream-p (stream)
  (cond ((ansi-streamp stream)
         (funcall *ansi-input-stream-p* stream))
        (t
         (assert-stream stream)
         nil)))

(defmethod gray-input-character-stream-p (stream)
  (cond ((ansi-streamp stream)
         (funcall *ansi-input-character-stream-p* stream))
        (t
         (assert-stream stream)
         nil)))

(defmethod gray-output-stream-p (stream)
  (cond ((ansi-streamp stream)
         (funcall *ansi-output-stream-p* stream))
        (t
         (assert-stream stream)
         nil)))

(defmethod gray-interactive-stream-p (stream)
  (cond ((ansi-streamp stream)
         (funcall *ansi-interactive-stream-p* stream))
        (t
         (assert-stream stream)
         nil)))

(defmethod gray-open-stream-p (stream)
  (cond ((ansi-streamp stream)
         (funcall *ansi-open-stream-p* stream))
        (t
         (assert-stream stream)
         nil)))

(defmethod gray-streamp (stream)
  (funcall *ansi-streamp* stream))

(defmethod gray-pathname (pathspec)
  (unless (typep pathspec '(or string pathname stream))
    (error 'type-error :datum pathspec :expected-type '(or string pathname stream)))
  (funcall *ansi-pathname* pathspec))

(defmethod gray-truename (pathspec)
  (unless (typep pathspec '(or string pathname stream))
    (error 'type-error :datum pathspec :expected-type '(or string pathname stream)))
  (funcall *ansi-truename* pathspec))

(defun gray-write-sequence (sequence stream &key (start 0) end)
  (if (ansi-streamp stream)
      (funcall *ansi-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)
  (if (ansi-streamp stream)
      (funcall *ansi-read-sequence* sequence stream :start start :end end)
      (stream-read-sequence stream sequence start end)))

(defgeneric stream-file-position (stream &optional position-spec))

(defun gray-file-position (stream &optional position-spec)
  (if position-spec
      (if (ansi-streamp stream)
          (funcall *ansi-file-position* stream position-spec)
          (stream-file-position stream position-spec))
      (if (ansi-streamp stream)
          (funcall *ansi-file-position* stream)
          (stream-file-position stream))))

(defgeneric stream-file-length (stream)
  (:method (stream)
    (error 'type-error
           :datum stream
           :expected-type 'file-stream)))

(defun gray-file-length (stream)
  (if (ansi-streamp stream)
      (funcall *ansi-file-length* stream)
      (stream-file-length stream)))

(defgeneric stream-file-string-length (stream object))

(defmethod stream-file-string-length
    ((stream fundamental-character-output-stream) object)
  (declare (ignore object))
  nil)

(defun gray-file-string-length (stream object)
  (if (ansi-streamp stream)
      (funcall *ansi-file-string-length* stream object)
      (stream-file-string-length stream object)))

#|
(defstruct (two-way-stream-g (:include stream))
  input-stream output-stream)

(defun gray-make-two-way-stream (in out)
  (if (and (ansi-streamp in) (ansi-streamp out))
      (funcall *ansi-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 (ansi-streamp stream)
      (funcall *ansi-two-way-stream-input-stream* stream)
      (two-way-stream-g-input-stream stream)))

(defun gray-two-way-stream-output-stream (stream)
  (if (ansi-streamp stream)
      (funcall *ansi-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 'sys::%output-object) #'gray-output-object)
(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 (fdefinition '(setf common-lisp::stream-element-type)) #'(setf gray-stream-element-type))
(setf (symbol-function 'common-lisp::stream-external-format) #'gray-stream-external-format)
(setf (fdefinition '(setf common-lisp::stream-external-format)) #'(setf gray-stream-external-format))
(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::interactive-stream-p) #'gray-interactive-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::file-position) #'gray-file-position)
(setf (symbol-function 'common-lisp::file-length) #'gray-file-length)
(setf (symbol-function 'common-lisp::file-string-length) #'gray-file-string-length)
(setf (symbol-function 'common-lisp::listen) #'gray-listen)
(setf (symbol-function 'ext:line-length) #'gray-line-length)
(setf (symbol-function 'common-lisp::pathname) #'gray-pathname)
(setf (symbol-function 'common-lisp::truename) #'gray-truename)

(dolist (e '((common-lisp::read-char gray-read-char)
             (common-lisp::peek-char gray-peek-char)
             (common-lisp::unread-char gray-unread-char)
             (common-lisp::read-line gray-read-line)
             (common-lisp::clear-input gray-clear-input)
             (common-lisp::read-char-no-hang gray-read-char-no-hang)
             (common-lisp::write-char gray-write-char)
             (common-lisp::fresh-line gray-fresh-line)
             (common-lisp::terpri gray-terpri)
             (common-lisp::write-string gray-write-string)
             (common-lisp::write-line gray-write-line)
             (sys::%force-output gray-force-output)
             (sys::%finish-output gray-finish-output)
             (sys::%clear-output gray-clear-output)
             (sys::%output-object gray-output-object)
             (common-lisp::read-byte gray-read-byte)
             (common-lisp::write-byte gray-write-byte)
             (common-lisp::stream-column gray-stream-column)
             (common-lisp::stream-element-type gray-stream-element-type)
             (common-lisp::stream-external-format gray-stream-external-format)
             (common-lisp::close gray-close)
             (common-lisp::input-stream-p gray-input-stream-p)
             (common-lisp::input-character-stream-p gray-input-character-stream-p) ;; # fb 1.01
             (common-lisp::output-stream-p gray-output-stream-p)
             (common-lisp::open-stream-p gray-open-stream-p)
             (common-lisp::streamp gray-streamp)
             (common-lisp::read-sequence gray-read-sequence)
             (common-lisp::write-sequence gray-write-sequence)
             (common-lisp::file-position gray-file-position)
             (common-lisp::file-length gray-file-length)
             (common-lisp::file-string-length gray-file-string-length)
             (common-lisp::listen gray-listen)
             (common-lisp::pathname gray-pathname)
             (common-lisp::truename gray-truename)))
  (sys::put (car e) 'sys::source (cl:get (second e) 'sys::source)))

#|
(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)
|#

(eval-when (:load-toplevel)
  (mapcar (lambda (o) (mop:finalize-inheritance (find-class o)))
          '(fundamental-stream 
            fundamental-input-stream fundamental-output-stream
            fundamental-character-stream 
            fundamental-character-input-stream fundamental-character-output-stream
            fundamental-binary-stream
            fundamental-binary-input-stream fundamental-binary-output-stream)))
 
(provide 'gray-streams)

;;; Fixup Gray/ANSI stream relations 

(defparameter *sys--stream-charpos* #'sys::stream-charpos)
(defun sys::stream-charpos (stream)
  (cond         
    ((subtypep (type-of stream) 'gray-streams:fundamental-stream)
     (stream-line-column stream))
    ((streamp stream)
     (funcall *sys--stream-charpos* stream))))

(defparameter *sys--stream-%set-charpos* #'sys::stream-%set-charpos)
(defun sys::stream-%set-charpos (new-value stream)
  (cond 
    ((subtypep (type-of stream) 'gray-streams:fundamental-stream)
     (setf (stream-line-column stream) new-value))
    ((streamp stream)
     (funcall *sys--stream-%set-charpos* stream new-value))))