Commit 1024d79c1960b6a4cb16ed8e54dde5ddb1e71960

Thomas de Grivel 2018-04-17T15:57:24

wip

diff --git a/cl-stream.lisp b/cl-stream.lisp
index ced8c3b..6330615 100644
--- a/cl-stream.lisp
+++ b/cl-stream.lisp
@@ -1,6 +1,15 @@
 
 (in-package :cl-stream)
 
+;#+sbcl ;; duh ??
+;(defmethod sb-mop:compute-slots ((class sb-pcl:system-class))
+;  )
+
+;(eval-when (:compile-toplevel :load-toplevel :execute)
+;  (closer-mop:add-direct-subclass
+;   (find-class 'io-stream)
+;   (find-class 'cl:stream)))
+
 (defmethod stream-close ((stream cl:stream))
   (cl:close stream))
 
diff --git a/fundamental-character-input-stream.lisp b/fundamental-character-input-stream.lisp
new file mode 100644
index 0000000..74f0cf0
--- /dev/null
+++ b/fundamental-character-input-stream.lisp
@@ -0,0 +1,48 @@
+
+(in-package :cl-stream)
+
+(defmethod stream-close ((stream cl:stream))
+  (cl:close stream)
+  (call-next-method))
+
+(defmethod stream-element-type ((stream cl:stream))
+  (cl:stream-element-type stream))
+
+(defmethod stream-finish ((stream cl:stream))
+  (cl:finish-output stream))
+
+(defmethod stream-open-p ((stream cl:stream))
+  (cl:open-stream-p stream))
+
+(defmethod stream-read ((stream cl:stream))
+  (let ((element-type (cl:stream-element-type stream)))
+    (cond ((subtypep element-type 'unsigned-byte)
+           (let ((byte (cl:read-byte stream nil +eof+)))
+             (if (eq +eof+ byte)
+                 (values nil :eof)
+                 (values byte nil))))
+          ((subtypep element-type 'character)
+           (let ((char (cl:read-char stream nil +eof+ nil)))
+             (if (eq +eof+ char)
+                 (values nil :eof)
+                 (values char nil))))
+          (t
+           (error "Unknown stream element type ~S" element-type)))))
+
+(defmethod stream-read-sequence ((stream cl:stream) (seq sequence)
+                                 &key (start 0) (end (length seq)))
+  (let ((pos (cl:read-sequence seq stream :start start :end end)))
+    (values (- pos start) nil)))
+
+(defmethod stream-write ((stream cl:stream) (element integer))
+  (cl:write-byte element stream)
+  nil)
+
+(defmethod stream-write ((stream cl:stream) (element character))
+  (cl:write-char element stream)
+  nil)
+
+(defmethod stream-write-sequence ((stream cl:stream) (seq sequence)
+                                  &key (start 0) (end (length seq)))
+  (cl:write-sequence seq stream :start start :end end)
+  (values (- end start) nil))
diff --git a/package.lisp b/package.lisp
index a9025e6..03eff94 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,5 +1,4 @@
-;;
-;;  cl-stream  -  Stream classes for Common Lisp
+;;;;  cl-stream  -  Stream classes for Common Lisp
 ;;
 ;;  Copyright 2017,2018 Thomas de Grivel <thoxdg@gmail.com>
 ;;
@@ -20,8 +19,7 @@
 
 (defpackage :cl-stream
   (:nicknames :stream)
-  (:use
-   :common-lisp)
+  (:use :common-lisp)
   (:shadow
    #:close
    #:input-stream
diff --git a/sequence-output-stream.lisp b/sequence-output-stream.lisp
index 2782ccc..4dcf65f 100644
--- a/sequence-output-stream.lisp
+++ b/sequence-output-stream.lisp
@@ -21,63 +21,27 @@
 (defclass sequence-output-stream (buffered-output-stream)
   ((open-p :initform t
            :accessor stream-open-p
-           :type boolean))
+           :type boolean)
+   (element-type :initarg :element-type
+                 :initform t
+                 :reader stream-element-type))
   (:documentation "A buffered output stream that writes to a sequence."))
 
 (defgeneric sequence-output-stream-sequence (sequence-output-stream)
   (:documentation "Returns the sequence that was written to
 SEQUENCE-OUTPUT-STREAM."))
 
-(defgeneric sequence-output-stream-reset (sequence-output-stream))
+(defgeneric sequence-output-stream-reset (sequence-output-stream)
+  (:documentation "Resets SEQUENCE-OUTPUT-STREAM to an empty
+ sequence."))
 
-(defmethod sequence-output-stream-sequence ((stream sequence-output-stream))
-  (subseq (stream-output-buffer stream) 0 (stream-output-length stream)))
-
-(defmethod sequence-output-stream-reset ((stream sequence-output-stream))
-  (setf (stream-output-length stream) 0))
-
-(defmethod initialize-instance ((stream sequence-output-stream)
-                                &rest initargs
-                                &key element-type &allow-other-keys)
-  (declare (ignore initargs))
-  (call-next-method)
-  (setf (slot-value stream 'output-buffer)
-        (make-array `(,*stream-default-buffer-size*)
-                    :element-type element-type
-                    :adjustable t)))
+(defmethod sequence-output-stream-sequence ((stream
+                                             sequence-output-stream))
+  (subseq (stream-output-buffer stream)
+          0 (stream-output-length stream)))
 
 (defmethod stream-close ((stream sequence-output-stream))
   (setf (stream-open-p stream) nil))
 
-(defmethod stream-element-type ((stream sequence-output-stream))
-  (array-element-type (stream-output-buffer stream)))
-
-(defmethod stream-output-buffer-size ((stream sequence-output-stream))
-  (length (stream-output-buffer stream)))
-
 (defmethod stream-flush ((stream sequence-output-stream))
   nil)
-
-(defmethod stream-flush-output-buffer ((stream sequence-output-stream))
-  (setf (slot-value stream 'output-buffer)
-        (let ((output-buffer (stream-output-buffer stream)))
-          (adjust-array output-buffer
-                        `(,(+ (length output-buffer)
-                              *stream-default-buffer-size*)))))
-  nil)
-
-(defmacro with-output-to-sequence ((var element-type) &body body)
-  "Binds VAR to a new sequence output stream with element-type
-ELEMENT-TYPE. Returns the sequence output stream sequence if
-BODY returns normally. The stream is closed after BODY returns
-normally or before it is aborted by a control transfer of some kind."
-  (let ((stream (gensym "STREAM-")))
-    `(let ((,stream (make-instance 'sequence-output-stream
-                                   :element-type ,element-type)))
-       (unwind-protect (let ((,var ,stream))
-                         ,@body
-                         (sequence-output-stream-sequence ,stream))
-         (close ,stream)))))
-
-(defmacro with-output-to-string ((var) &body body)
-  `(with-output-to-sequence (,var 'string) ,@body))
diff --git a/vector-output-stream.lisp b/vector-output-stream.lisp
new file mode 100644
index 0000000..7605883
--- /dev/null
+++ b/vector-output-stream.lisp
@@ -0,0 +1,55 @@
+;;
+;;  cl-stream  -  Stream classes for Common Lisp
+;;
+;;  Copyright 2017,2018 Thomas de Grivel <thoxdg@gmail.com>
+;;
+;;  Permission to use, copy, modify, and distribute this software for any
+;;  purpose with or without fee is hereby granted, provided that the above
+;;  copyright notice and this permission notice appear in all copies.
+;;
+;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(in-package :cl-stream)
+
+(defclass vector-output-stream (sequence-output-stream)
+  ())
+
+(defmethod make-stream-output-buffer ((stream vector-output-stream))
+  (make-vector `(,(stream-output-buffer-size stream))
+              :element-type (stream-element-type stream)))
+
+(defmethod stream-flush-output ((stream vector-output-stream))
+  (setf (slot-value stream 'output-buffer)
+        (let* ((output-buffer (stream-output-buffer stream))
+               (length (length output-buffer))
+               (size (stream-output-buffer-size stream))
+               (new-size (+ length size)))
+          (adjust-array output-buffer `(,new-size))))
+  nil)
+
+(defmethod stream-write-element-to-buffer ((stream vector-output-stream)
+                                           element)
+  (setf (aref (stream-output-buffer stream) (stream-output-length stream))
+        element)
+  (incf (stream-output-length stream))
+  nil)
+
+(defmacro with-output-to-vector ((var &optional (element-type t))
+                                &body body)
+  "Binds VAR to a new vector output stream with element-type
+ELEMENT-TYPE. Returns the output vector if BODY returns normally.
+The stream is closed after BODY returns normally or before it is
+aborted by a control transfer of some kind."
+  (let ((stream (gensym "STREAM-")))
+    `(with-stream (,stream (make-instance 'vector-output-stream
+                                          :element-type ,element-type))
+       (let ((,var ,stream))
+         ,@body
+         (sequence-output-stream-sequence ,stream)))))