binary-stream.lisp

binary-stream.lisp

(deftype rawdata () '(array (unsigned-byte 8) 1))

(defclass memstream (fundamental-binary-input-stream fundamental-binary-output-stream)
  ((data :initarg :data
         :type rawdata
         :initform (make-array 0 :adjustable t
                                 :fill-pointer 0
                                 :element-type '(unsigned-byte 8))
         :accessor memstream-data)
   (size :initarg :size
         :initform 0
         :type (integer 0 #.array-total-size-limit)
         :accessor memstream-size)))

(defmethod stream-file-position ((stream memstream))
  (with-slots (data) stream
    (fill-pointer data)))

(defmethod (setf stream-file-position) (position (stream memstream))
  (with-slots (data) stream
    (setf (fill-pointer data) position)))

(defmethod stream-read-byte ((stream memstream))
  (with-slots (data size) stream
    (let ((pos (fill-pointer data)))
      (cond
        ((< pos size)
         (incf (fill-pointer data))
         (aref data pos))
        (t :eof)))))

(defmethod stream-write-byte ((stream memstream) byte)
  (with-slots (data size) stream
    (when (= size (vector-push-extend byte data))
      (incf size))))

(defmethod stream-read-sequence ((stream memstream) sequence start end &key)
  (with-slots (data) stream
    (let ((position (fill-pointer data))
          (length (- end start)))
      (incf (fill-pointer data) length)
      (replace sequence data :start1 start :end1 end :start2 position :end2 (+ position length))
      length)))

(defmethod stream-write-sequence ((stream memstream) sequence start end &key)
  (with-slots (data size) stream
    (let* ((position (fill-pointer data))
           (length (- end start))
           (space (array-total-size data))
           (end1 (+ position length))
           (diff (- end1 space)))
      (adjust-array data (+ space diff) :fill-pointer end1)
      (setf size (max size end1))
      (replace data sequence :start1 position :end1 end1 :start2 start :end2 end))))

(defgeneric memstream-whole-data (stream)
  (:method ((stream memstream))
    (with-slots (data size) stream
      (make-array size :element-type '(unsigned-byte 8)
                       :displaced-to data
                       :fill-pointer size))))

(defun make-memstream (&optional data)
  (if data
      (make-instance 'memstream
                     :size (length data)
                     :data (make-array (length data)
                                       :element-type '(unsigned-byte 8)
                                       :displaced-to data
                                       :fill-pointer 0))
      (make-instance 'memstream)))