src/base/dynamic-buffer.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Read/write adjustable buffer.
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 (defclass dynamic-buffer ()
   9   ((sequence     :initform nil :accessor sequence-of)
  10    (read-cursor  :initform 0   :accessor read-cursor-of)
  11    (write-cursor :initform 0   :accessor write-cursor-of)
  12    (growth-size  :initarg :growth-size :accessor growth-size-of))
  13   (:default-initargs :growth-size 3/2))
  14
  15 (defmethod initialize-instance :after ((buffer dynamic-buffer)
  16                                        &key (size 256) sequence (start 0) end)
  17   (etypecase sequence
  18     (null
  19      (setf (sequence-of buffer) (make-array size :element-type 'ub8)))
  20     (ub8-vector
  21      (check-bounds sequence start end)
  22      (let* ((sequence-size (- end start))
  23             (newseq (make-array sequence-size :element-type 'ub8)))
  24        (replace newseq sequence :start2 start :end2 end)
  25        (setf (sequence-of buffer)     newseq
  26              (write-cursor-of buffer) sequence-size)))))
  27
  28 (defmethod print-object ((buffer dynamic-buffer) stream)
  29   (print-unreadable-object (buffer stream :type t :identity t)
  30     (let ((*print-length* 40))
  31       (format stream "Size: ~A RC: ~A WC: ~A Contents: ~S"
  32               (size-of buffer)
  33               (read-cursor-of buffer)
  34               (write-cursor-of buffer)
  35               (sequence-of buffer)))))
  36
  37 (defgeneric size-of (buffer)
  38   (:method ((buffer dynamic-buffer))
  39     (length (sequence-of buffer))))
  40
  41 (declaim (inline ub16-to-vector))
  42 (defun ub16-to-vector (value)
  43   (vector (ldb (byte 8 8) value)
  44           (ldb (byte 8 0) value)))
  45
  46 (declaim (inline ub32-to-vector))
  47 (defun ub32-to-vector (value)
  48   (vector (ldb (byte 8 32) value)
  49           (ldb (byte 8 16) value)
  50           (ldb (byte 8 8) value)
  51           (ldb (byte 8 0) value)))
  52
  53 (defun maybe-grow-buffer (buffer request-size)
  54   (with-accessors ((seq sequence-of)
  55                    (size size-of)
  56                    (wcursor write-cursor-of)
  57                    (growth-size growth-size-of))
  58       buffer
  59     (when (< size (+ wcursor request-size))
  60       (let ((newsize (* growth-size (+ size request-size))))
  61         (setf seq (adjust-array seq newsize)))))
  62   (values buffer))
  63
  64 (defun write-vector (buffer vector &optional (start 0) end)
  65   (check-bounds vector start end)
  66   (let ((request-size (- end start)))
  67     (maybe-grow-buffer buffer request-size)
  68     (with-accessors ((seq sequence-of)
  69                      (wcursor write-cursor-of))
  70         buffer
  71       (replace seq vector :start1 wcursor :start2 start :end2 end)
  72       (incf wcursor request-size)))
  73   (values buffer))
  74
  75 (declaim (inline write-ub8))
  76 (defun write-ub8 (buffer value)
  77   (write-vector buffer (vector value)))
  78
  79 (declaim (inline write-ub16))
  80 (defun write-ub16 (buffer value)
  81   (write-vector buffer (ub16-to-vector value)))
  82
  83 (declaim (inline write-ub32))
  84 (defun write-ub32 (buffer value)
  85   (write-vector buffer (ub32-to-vector value)))
  86
  87 (define-condition dynamic-buffer-input-error (error)
  88   ((buffer :initform (error "Must supply buffer")
  89            :initarg :buffer :reader buffer-of)))
  90
  91 (define-condition dynamic-buffer-eof (dynamic-buffer-input-error)
  92   ((octets-requested :initarg :requested :reader octets-requested-of)
  93    (octets-remaining :initarg :remaining :reader octets-remaining-of))
  94   (:report (lambda (condition stream)
  95              (format stream "You requested ~A octets but only ~A are left in the buffer"
  96                      (octets-requested-of condition)
  97                      (octets-remaining-of condition))))
  98   (:documentation
  99    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
 100
 101 (define-condition dynamic-buffer-index-out-of-bounds (dynamic-buffer-input-error)
 102   ((index :initarg :index :reader index-of))
 103   (:report (lambda (condition stream)
 104              (format stream "Trying to access ~A at invalid index ~A"
 105                      (buffer-of condition)
 106                      (index-of condition))))
 107   (:documentation
 108    "Signals that SEEK-READ-CURSOR on an INPUT-BUFFER was passed an invalid index."))
 109
 110 (declaim (inline seek-read-cursor))
 111 (defun seek-read-cursor (buffer index)
 112   (check-type index unsigned-byte "an unsigned-byte")
 113   (if (>= index (size-of buffer))
 114       (error 'dynamic-buffer-index-out-of-bounds :buffer buffer :index index)
 115       (setf (read-cursor-of buffer) index)))
 116
 117 (declaim (inline unread-bytes))
 118 (defun unread-bytes (buffer)
 119   (- (write-cursor-of buffer) (read-cursor-of buffer)))
 120
 121 (defun read-vector (buffer length)
 122   (with-accessors ((seq sequence-of)
 123                    (rcursor read-cursor-of))
 124       buffer
 125     (let* ((bytes-to-read (min (unread-bytes buffer) length))
 126            (newvector (make-array bytes-to-read :element-type 'ub8)))
 127       (replace newvector seq :start2 rcursor)
 128       (incf rcursor bytes-to-read)
 129       (values newvector))))
 130
 131 (defmacro read-ub-be (vector position &optional (length 1))
 132   `(+ ,@(loop :for i :below length
 133               :collect `(ash (aref ,vector (+ ,position ,i))
 134                              ,(* (- length i 1) 8)))))
 135
 136 (declaim (inline read-ub16-from-vector))
 137 (defun read-ub16-from-vector (vector position)
 138   (read-ub-be vector position 2))
 139
 140 (declaim (inline read-ub32-from-vector))
 141 (defun read-ub32-from-vector (vector position)
 142   (read-ub-be vector position 4))
 143
 144 (declaim (inline check-if-enough-bytes))
 145 (defun check-if-enough-bytes (buffer length)
 146   (let ((remaining-bytes (unread-bytes buffer)))
 147     (when (< remaining-bytes length)
 148       (error 'dynamic-buffer-eof
 149              :buffer buffer
 150              :requested length
 151              :remaining remaining-bytes))))
 152
 153 (declaim (inline read-ub8))
 154 (defun read-ub8 (buffer)
 155   (check-if-enough-bytes buffer 1)
 156   (prog1
 157       (aref (sequence-of buffer) (read-cursor-of buffer))
 158     (incf (read-cursor-of buffer))))
 159
 160 (declaim (inline read-ub16))
 161 (defun read-ub16 (buffer)
 162   (check-if-enough-bytes buffer 2)
 163   (prog1
 164       (read-ub16-from-vector (sequence-of buffer) (read-cursor-of buffer))
 165     (incf (read-cursor-of buffer) 2)))
 166
 167 (declaim (inline read-ub32))
 168 (defun read-ub32 (buffer)
 169   (check-if-enough-bytes buffer 4)
 170   (prog1
 171       (read-ub32-from-vector (sequence-of buffer) (read-cursor-of buffer))
 172     (incf (read-cursor-of buffer) 4)))