1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Read/write adjustable buffer.
6 (in-package :iolib.base
)
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))
15 (defmethod initialize-instance :after
((buffer dynamic-buffer
)
16 &key
(size 256) sequence
(start 0) end
)
19 (setf (sequence-of buffer
) (make-array size
:element-type
'ub8
)))
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
)))))
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"
33 (read-cursor-of buffer
)
34 (write-cursor-of buffer
)
35 (sequence-of buffer
)))))
37 (defgeneric size-of
(buffer)
38 (:method
((buffer dynamic-buffer
))
39 (length (sequence-of buffer
))))
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
)))
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
)))
53 (defun maybe-grow-buffer (buffer request-size
)
54 (with-accessors ((seq sequence-of
)
56 (wcursor write-cursor-of
)
57 (growth-size growth-size-of
))
59 (when (< size
(+ wcursor request-size
))
60 (let ((newsize (* growth-size
(+ size request-size
))))
61 (setf seq
(adjust-array seq newsize
)))))
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
))
71 (replace seq vector
:start1 wcursor
:start2 start
:end2 end
)
72 (incf wcursor request-size
)))
75 (declaim (inline write-ub8
))
76 (defun write-ub8 (buffer value
)
77 (write-vector buffer
(vector value
)))
79 (declaim (inline write-ub16
))
80 (defun write-ub16 (buffer value
)
81 (write-vector buffer
(ub16-to-vector value
)))
83 (declaim (inline write-ub32
))
84 (defun write-ub32 (buffer value
)
85 (write-vector buffer
(ub32-to-vector value
)))
87 (define-condition dynamic-buffer-input-error
(error)
88 ((buffer :initform
(error "Must supply buffer")
89 :initarg
:buffer
:reader buffer-of
)))
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
))))
99 "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
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
))))
108 "Signals that SEEK-READ-CURSOR on an INPUT-BUFFER was passed an invalid index."))
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
)))
117 (declaim (inline unread-bytes
))
118 (defun unread-bytes (buffer)
119 (- (write-cursor-of buffer
) (read-cursor-of buffer
)))
121 (defun read-vector (buffer length
)
122 (with-accessors ((seq sequence-of
)
123 (rcursor read-cursor-of
))
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
))))
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)))))
136 (declaim (inline read-ub16-from-vector
))
137 (defun read-ub16-from-vector (vector position
)
138 (read-ub-be vector position
2))
140 (declaim (inline read-ub32-from-vector
))
141 (defun read-ub32-from-vector (vector position
)
142 (read-ub-be vector position
4))
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
151 :remaining remaining-bytes
))))
153 (declaim (inline read-ub8
))
154 (defun read-ub8 (buffer)
155 (check-if-enough-bytes buffer
1)
157 (aref (sequence-of buffer
) (read-cursor-of buffer
))
158 (incf (read-cursor-of buffer
))))
160 (declaim (inline read-ub16
))
161 (defun read-ub16 (buffer)
162 (check-if-enough-bytes buffer
2)
164 (read-ub16-from-vector (sequence-of buffer
) (read-cursor-of buffer
))
165 (incf (read-cursor-of buffer
) 2)))
167 (declaim (inline read-ub32
))
168 (defun read-ub32 (buffer)
169 (check-if-enough-bytes buffer
4)
171 (read-ub32-from-vector (sequence-of buffer
) (read-cursor-of buffer
))
172 (incf (read-cursor-of buffer
) 4)))