From 150a211446dc445a227318223f6c77f76f2edc13 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 5 May 1998 00:33:20 +0000
Subject: [PATCH] Gray streams support for CMUCL.

---
 pcl/gray-streams-class.lisp |  54 ++++++
 pcl/gray-streams.lisp       | 320 ++++++++++++++++++++++++++++++++++++
 2 files changed, 374 insertions(+)
 create mode 100644 pcl/gray-streams-class.lisp
 create mode 100644 pcl/gray-streams.lisp

diff --git a/pcl/gray-streams-class.lisp b/pcl/gray-streams-class.lisp
new file mode 100644
index 000000000..6b25a4c33
--- /dev/null
+++ b/pcl/gray-streams-class.lisp
@@ -0,0 +1,54 @@
+;;;
+;;; **********************************************************************
+;;; This code was written by Douglas T. Crosher and has been placed in
+;;; the Public domain, and is provided 'as is'.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.1 1998/05/05 00:33:19 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Class definitions for the CMUCL Gray streams implementation.
+;;;
+
+(in-package "LISP")
+
+
+
+;;; Bootstrap the fundamental-stream class.
+(let ((pcl::*pcl-class-boot* 'fundamental-stream))
+  (defclass fundamental-stream (standard-object stream)
+    ()
+    (:documentation "Base class for all CLOS streams")))
+
+;;; Define the stream classes.
+(defclass fundamental-input-stream (fundamental-stream))
+
+(defclass fundamental-output-stream (fundamental-stream))
+
+(defclass fundamental-character-stream (fundamental-stream))
+
+(defclass fundamental-binary-stream (fundamental-stream))
+
+(defclass fundamental-character-input-stream
+    (fundamental-input-stream fundamental-character-stream))
+
+(defclass fundamental-character-output-stream
+    (fundamental-output-stream fundamental-character-stream))
+
+(defclass fundamental-binary-input-stream
+    (fundamental-input-stream fundamental-binary-stream))
+
+(defclass fundamental-binary-output-stream
+    (fundamental-output-stream fundamental-binary-stream))
+
+
+;;; Example character input and output streams.
+
+(defclass character-output-stream (fundamental-character-output-stream)
+  ((lisp-stream :initarg :lisp-stream
+		:accessor character-output-stream-lisp-stream)))
+
+(defclass character-input-stream (fundamental-character-input-stream)
+  ((lisp-stream :initarg :lisp-stream
+		:accessor character-input-stream-lisp-stream)))
diff --git a/pcl/gray-streams.lisp b/pcl/gray-streams.lisp
new file mode 100644
index 000000000..289a79af1
--- /dev/null
+++ b/pcl/gray-streams.lisp
@@ -0,0 +1,320 @@
+;;;
+;;; **********************************************************************
+;;; This code was written by Douglas T. Crosher and has been placed in
+;;; the Public domain, and is provided 'as is'.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams.lisp,v 1.1 1998/05/05 00:33:20 dtc Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Gray streams implementation for CMUCL.
+;;;
+
+(in-package "LISP")
+
+
+
+(fmakunbound 'stream-element-type)
+
+(defgeneric stream-element-type (stream)
+  (:documentation "Returns a type specifier for the kind of object returned by the Stream."))
+
+(defmethod stream-element-type ((stream lisp-stream))
+  (funcall (lisp-stream-misc stream) stream :element-type))
+
+(defmethod stream-element-type ((stream fundamental-character-stream))
+  'character)
+
+
+
+(defgeneric pcl-open-stream-p (stream)
+  (:documentation "Return true if Stream is not closed."))
+
+(defmethod pcl-open-stream-p ((stream lisp-stream))
+  (not (eq (lisp-stream-in stream) #'closed-flame)))
+
+(defmethod pcl-open-stream-p ((stream fundamental-stream))
+  nil)
+
+;;; Bootstrapping hack.
+(pcl-open-stream-p (make-string-output-stream))
+(setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)
+
+
+
+
+(defgeneric pcl-close (stream &key abort)
+  (:documentation "Closes the given Stream.  No more I/O may be performed, but inquiries
+  may still be made.  If :Abort is non-nil, an attempt is made to clean
+  up the side effects of having created the stream."))
+
+(defmethod pcl-close ((stream lisp-stream) &key abort)
+  (when (open-stream-p stream)
+    (funcall (lisp-stream-misc stream) stream :close abort))
+  t)
+
+(setf (fdefinition 'close) #'pcl-close)
+
+
+
+(fmakunbound 'input-stream-p)
+
+(defgeneric input-stream-p (stream)
+  (:documentation "Returns non-nil if the given Stream can perform input operations."))
+
+(defmethod input-stream-p ((stream lisp-stream))
+  (and (not (eq (lisp-stream-in stream) #'closed-flame))
+       (or (not (eq (lisp-stream-in stream) #'ill-in))
+	   (not (eq (lisp-stream-bin stream) #'ill-bin)))))
+
+(defmethod input-stream-p ((stream fundamental-input-stream))
+  t)
+
+
+
+(fmakunbound 'output-stream-p)
+
+(defgeneric output-stream-p (stream)
+  (:documentation "Returns non-nil if the given Stream can perform output operations."))
+
+(defmethod output-stream-p ((stream lisp-stream))
+  (and (not (eq (lisp-stream-in stream) #'closed-flame))
+       (or (not (eq (lisp-stream-out stream) #'ill-out))
+	   (not (eq (lisp-stream-bout stream) #'ill-bout)))))
+
+(defmethod output-stream-p ((stream fundamental-output-stream))
+  t)
+
+
+;;; Character input streams.
+
+(defgeneric stream-read-char (stream)
+  (:documentation "Reads one character, :eof on end of file."))
+
+(defgeneric stream-unread-char (stream character)
+  (:documentation "Unreads one character, and returns nil."))
+
+(defgeneric stream-read-char-no-hang (stream)
+  (:documentation "Reads either a character, or NIL is none is available,
+  and :eof on end of file."))
+
+(defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
+  (stream-read-char stream))
+
+(defgeneric stream-peek-char (stream)
+  (:documentation "Reads either a character or :eof without removing the character
+  from the stream."))
+
+(defmethod stream-peek-char ((stream fundamental-character-input-stream))
+  (let ((char (stream-read-char stream)))
+    (unless (eq char :eof)
+      (stream-unread-char stream char))
+    char))
+
+(defgeneric stream-listen (stream)
+  (:documentation "Return true if input is available, otherwise false."))
+
+(defmethod stream-listen ((stream fundamental-character-input-stream))
+  (let ((char (stream-read-char-no-hang stream)))
+    (when (characterp char)
+      (stream-unread-char stream char)
+      char)))
+
+(defgeneric stream-read-line (stream)
+  (:documentation "Reads the first line, and returns a string and T as the second
+  value if the line was terminated by end-of-file."))
+
+(defmethod stream-read-line ((stream fundamental-character-input-stream))
+  (let ((res (make-string 80))
+	(len 80)
+	(index 0))
+    (loop
+     (let ((ch (stream-read-char stream)))
+       (cond ((eq ch :eof)
+	      (return (values (shrink-vector res index) t)))
+	     (t
+	      (when (char= ch #\newline)
+		(return (values (shrink-vector res index) nil)))
+	      (when (= index len)
+		(setq len (* len 2))
+		(let ((new (make-string len)))
+		  (replace new res)
+		  (setq res new)))
+	      (setf (schar res index) ch)
+	      (incf index)))))))
+
+(defgeneric stream-clear-input (stream)
+  (:documentation "Clears buffered input, and returns Nil."))
+
+(defmethod stream-clear-input ((stream fundamental-character-input-stream))
+  nil)
+
+
+;;; Character output streams.
+
+(defgeneric stream-write-char (stream character)
+  (:documentation "Outputs the Character to the Stream."))
+
+(defgeneric stream-line-column (stream)
+  (:documentation "Return the current column number for the stream or Nil."))
+
+;;; Stream-line-length is a CMUCL extension to Gray streams.
+(defgeneric stream-line-length (stream)
+  (:documentation "Return the stream line length or Nil."))
+
+(defmethod stream-line-length ((stream fundamental-character-output-stream))
+  nil)
+
+(defgeneric stream-start-line-p (stream)
+  (:documentation "Return true when at the start of a line otherwise false."))
+
+(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
+  (eql (stream-line-column stream) 0))
+
+(defgeneric stream-write-string (stream string &optional (start 0) end)
+  (:documentation "Outputs the String to the given Stream."))
+
+(defmethod stream-write-string ((stream fundamental-character-output-stream)
+				string &optional (start 0) end)
+  (declare (string string)
+	   (fixnum start))
+  (let ((end (or end (length string))))
+    (declare (fixnum end))
+    (do ((pos start (1+ pos)))
+	((>= pos end))
+      (declare (type index pos))
+      (stream-write-char stream (aref string pos))))
+  string)
+
+(defgeneric stream-terpri (stream)
+  (:documentation "Outputs a new line to the Stream."))
+
+(defmethod stream-terpri ((stream fundamental-character-output-stream))
+  (stream-write-char stream #\Newline))
+
+(defgeneric stream-fresh-line (stream)
+  (:documentation "Outputs a new line to the Stream if it is not positioned at the begining of
+   a line.  Returns T if it output a new line, nil otherwise."))
+
+(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
+  (unless (stream-start-line-p stream)
+    (stream-terpri stream)
+    t))
+
+(defgeneric stream-finish-output (stream)
+  (:documentation "Attempts to ensure that all output sent to the Stream has reached its
+   destination, and only then returns false."))
+
+(defmethod stream-finish-output ((stream fundamental-output-stream))
+  nil)
+
+(defgeneric stream-force-output (stream)
+  (:documentation "Attempts to force any buffered output to be sent."))
+
+(defmethod stream-force-output ((stream fundamental-output-stream))
+  nil)
+
+(defgeneric stream-clear-output (stream)
+  (:documentation "Clears the given output Stream."))
+
+(defmethod stream-clear-output ((stream fundamental-output-stream))
+  nil)
+
+(defgeneric stream-advance-to-column (stream column)
+  (:documentation "Write enough space to the stream so that the next character is
+  written to the given column. Returns true if successful, or false if not
+  supported."))
+
+(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
+				     column)
+  (let ((current-column (stream-line-column stream)))
+    (when current-column
+      (let ((fill (- column current-column)))
+	(dotimes (i fill)
+	  (stream-write-char stream #\Space)))
+      T)))
+
+
+;;; Binary streams.
+
+(defgeneric stream-read-byte (stream)
+  (:documentation "Returns an integer of :eof."))
+
+(defgeneric stream-write-byte (stream integer)
+  (:documentation "Writes integer to stream, returning integer."))
+
+
+;;; Example character output stream encapsulating a lisp-stream.
+(defun make-character-output-stream (lisp-stream)
+  (declare (type lisp-stream lisp-stream))
+  (make-instance 'character-output-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-output-stream))
+  (open-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-output-stream) &key abort)
+  (close (character-output-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-output-stream))
+  (input-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-output-stream))
+  (output-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-write-char ((stream character-output-stream) character)
+  (write-char character (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-column ((stream character-output-stream))
+  (charpos (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-length ((stream character-output-stream))
+  (line-length (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-finish-output ((stream character-output-stream))
+  (finish-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-force-output ((stream character-output-stream))
+  (force-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream character-output-stream))
+  (clear-output (character-output-stream-lisp-stream stream)))
+
+
+;;; Example character input stream encapsulating a lisp-stream.
+
+(defun make-character-input-stream (lisp-stream)
+  (declare (type lisp-stream lisp-stream))
+  (make-instance 'character-input-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-input-stream))
+  (open-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-input-stream) &key abort)
+  (close (character-input-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-input-stream))
+  (input-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-input-stream))
+  (output-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char ((stream character-input-stream))
+  (read-char (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-unread-char ((stream character-input-stream) character)
+  (unread-char character (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char-no-hang ((stream character-input-stream))
+  (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-peek-char ((stream character-input-stream))
+  (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-listen ((stream character-input-stream))
+  (listen (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-clear-input ((stream character-input-stream))
+  (clear-input (character-input-stream-lisp-stream stream)))
-- 
GitLab