src/raw-memory-streams.lisp

   1 (uiop:define-package #:lw2.raw-memory-streams
   2   (:use #:cl #:trivial-gray-streams)
   3   (:export #:raw-memory-stream))
   4
   5 (in-package #:lw2.raw-memory-streams)
   6
   7 (defclass raw-memory-stream (fundamental-binary-input-stream)
   8   ((pointer :initarg :pointer)
   9    (length :initarg :length :initform (error "No length parameter supplied when creating raw-memory-stream") :type (and fixnum (integer 0)))
  10    (position :initform 0 :type fixnum :accessor stream-file-position)))
  11
  12 (defmethod stream-element-type ((self raw-memory-stream))
  13   '(unsigned-byte 8))
  14
  15 (defmethod stream-read-byte ((self raw-memory-stream))
  16   (declare (optimize (safety 0) (debug 0)))
  17   (with-slots (pointer length position) self
  18     (declare (type (and fixnum (integer 0)) length position)
  19              (type cffi:foreign-pointer pointer))
  20     (if (>= position length)
  21         :eof
  22         (prog1
  23             (cffi:mem-aref pointer :unsigned-char position)
  24           (setf position (the fixnum (+ 1 position)))))))
  25
  26 (defmethod stream-read-sequence ((self raw-memory-stream) sequence start end &key)
  27   (declare (optimize (safety 0) (debug 0))
  28            (type (and fixnum (integer 0)) start end))
  29   (with-slots (pointer length position) self
  30     (declare (type (and fixnum (integer 0)) length position)
  31              (type cffi:foreign-pointer pointer))
  32     (let* ((remaining-length (- length position))
  33            (requested-length (- end start))
  34            (actual-length (min remaining-length requested-length)))
  35       (declare (type (and fixnum (integer 0)) remaining-length requested-length actual-length))
  36       (macrolet ((inner ()
  37                    `(loop for mem-index from position to (+ position actual-length)
  38                        for sequence-index from start
  39                        do (setf (elt sequence sequence-index)
  40                                 (cffi:mem-aref pointer :unsigned-char mem-index)))))
  41           (etypecase sequence
  42             ((simple-array (unsigned-byte 8) (*)) (inner))
  43             ((array (unsigned-byte 8) (*)) (inner))
  44             (sequence (inner))))
  45       (setf position (the fixnum (+ position actual-length)))
  46       (the fixnum (+ start actual-length)))))