All Downloads are FREE. Search and download functionalities are using the official Maven repository.
Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance.
Project price only 1 $
You can buy this project and download/modify it how often you want.
org.armedbear.lisp.gray-streams.lisp Maven / Gradle / Ivy
;;; gray-streams.lisp
;;;
;;; Copyright (C) 2004-2007 Peter Graves, Andras Simon
;;; $Id$
;;;
;;; 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: [email protected]
;;;;
;;;; 03/03/2001 - 1.0
;;;; Initial release.
;;;;
;;;; 20/08/2001 - 1.1
;;;; Small modifications by Frederic Bastenaire ([email protected] )
;;;; (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-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"
"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-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-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)
(defun ansi-streamp (stream)
(or (xp::xp-structure-p stream)
(funcall *ansi-streamp* stream)))
(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-stream-element-type (stream))
(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)
(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-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-write-string (stream string &optional start end))
(defgeneric stream-terpri (stream))
(defmethod stream-terpri (stream)
(stream-write-char stream #\Newline))
(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))
(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)
(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 (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))))
(defmethod gray-stream-element-type (stream)
(funcall *ansi-stream-element-type* stream))
(defmethod gray-close (stream &key abort)
(funcall *ansi-close* stream :abort abort))
(defmethod gray-input-stream-p (stream)
(funcall *ansi-input-stream-p* stream))
(defmethod gray-input-character-stream-p (stream)
(funcall *ansi-input-character-stream-p* stream))
(defmethod gray-output-stream-p (stream)
(funcall *ansi-output-stream-p* stream))
(defmethod gray-open-stream-p (stream)
(funcall *ansi-open-stream-p* stream))
(defmethod gray-streamp (stream)
(funcall *ansi-streamp* stream))
(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))))
#|
(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 (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::file-position) #'gray-file-position)
(setf (symbol-function 'common-lisp::listen) #'gray-listen)
(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::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::listen gray-listen)))
(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))))
