1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Device buffers.
6 (in-package :io.zeta-streams
)
8 ;;;-------------------------------------------------------------------------
10 ;;;-------------------------------------------------------------------------
13 ((synchronized :initarg
:synchronized
14 :reader synchronizedp
)
18 (input-iobuf :initarg
:input-buffer
19 :accessor input-iobuf-of
)
20 (output-iobuf :initarg
:output-buffer
21 :accessor output-iobuf-of
)
22 (buffering :initarg
:buffering
23 :accessor buffering-of
))
24 (:default-initargs
:synchronized nil
))
26 (defclass single-channel-buffer
(buffer)
27 ((last-io-op :initform nil
:accessor last-io-op-of
)))
29 (defclass dual-channel-buffer
(buffer) ())
32 ;;;-------------------------------------------------------------------------
34 ;;;-------------------------------------------------------------------------
36 (defgeneric buffer-fill
(buffer &key timeout
))
38 (defgeneric buffer-flush
(buffer &key timeout
))
40 (defgeneric buffer-wait-until-flushable
(buffer &key timeout
))
42 (defgeneric buffer-clear-input
(buffer))
44 (defgeneric buffer-clear-output
(buffer))
46 ;;; Internal functions
48 (defgeneric %buffer-read-vector
(buffer vector start end timeout
))
50 (defgeneric %buffer-write-vector
(buffer vector start end timeout
))
52 (defgeneric %buffer-fill
(buffer timeout
))
54 (defgeneric %buffer-flush
(buffer timeout
))
56 (defgeneric %buffer-clear-input
(buffer))
58 (defgeneric %buffer-clear-output
(buffer))
61 ;;;-------------------------------------------------------------------------
63 ;;;-------------------------------------------------------------------------
65 (defmacro with-synchronized-buffer
((buffer &optional direction
) &body body
)
66 (with-gensyms (body-fun)
67 (labels ((make-locks (body direction
)
71 ((iobuf-lock (input-iobuf-of ,buffer
)))
75 ((iobuf-lock (output-iobuf-of ,buffer
)))
78 (make-locks (make-locks body
:output
) :input
)))))
79 `(flet ((,body-fun
() ,@body
))
80 (if (synchronizedp ,buffer
)
81 ,(make-locks `(,body-fun
) direction
)
85 ;;;-------------------------------------------------------------------------
87 ;;;-------------------------------------------------------------------------
89 (defmethod shared-initialize :after
90 ((buffer single-channel-buffer
) slot-names
91 &key data size buffering
)
92 (declare (ignore slot-names
))
93 (with-accessors ((device device-of
)
94 (input-iobuf input-iobuf-of
)
95 (output-iobuf output-iobuf-of
))
97 (check-type device device
)
98 (check-type data
(or null iobuf
))
99 (check-type buffering stream-buffering
)
100 (setf input-iobuf
(or data
(make-iobuf size
))
101 output-iobuf input-iobuf
)))
103 (defmethod shared-initialize :after
104 ((buffer dual-channel-buffer
) slot-names
105 &key input-data output-data input-size output-size buffering
)
106 (declare (ignore slot-names
))
107 (with-accessors ((device device-of
)
108 (input-iobuf input-iobuf-of
)
109 (output-iobuf output-iobuf-of
))
111 (check-type device device
)
112 (check-type input-data
(or null iobuf
))
113 (check-type output-data
(or null iobuf
))
114 (check-type buffering stream-buffering
)
115 (setf input-iobuf
(or input-data
(make-iobuf input-size
)))
116 (setf output-iobuf
(or output-data
(make-iobuf output-size
)))))
119 ;;;-------------------------------------------------------------------------
121 ;;;-------------------------------------------------------------------------
123 (defmethod relinquish ((buffer single-channel-buffer
) &key abort
)
124 (with-accessors ((device device-of
))
126 (with-synchronized-buffer (buffer :input
)
127 (unless (or abort
(eql :read
(last-io-op-of buffer
)))
128 (%buffer-flush buffer
0))
129 (relinquish device
:abort abort
)))
132 (defmethod relinquish ((buffer dual-channel-buffer
) &key abort
)
133 (with-accessors ((device device-of
))
135 (with-synchronized-buffer (buffer :io
)
137 (%buffer-flush buffer
0))
138 (relinquish device
:abort abort
)))
142 ;;;-------------------------------------------------------------------------
144 ;;;-------------------------------------------------------------------------
146 (defmethod device-read :around
((buffer buffer
) vector
&key
147 (start 0) end timeout
)
148 (check-bounds vector start end
)
151 (call-next-method buffer vector
:start start
152 :end end
:timeout timeout
)))
154 (defmethod device-read ((buffer single-channel-buffer
) vector
155 &key start end timeout
)
156 (with-synchronized-buffer (buffer :input
)
157 (%buffer-read-vector buffer vector start end timeout
)))
159 (defmethod device-read ((buffer dual-channel-buffer
) vector
160 &key start end timeout
)
161 (with-synchronized-buffer (buffer :input
)
162 (%buffer-read-vector buffer vector start end timeout
)))
164 (defmethod %buffer-read-vector
((buffer buffer
) vector start end timeout
)
165 (with-accessors ((input-iobuf input-iobuf-of
)
166 (output-iobuf output-iobuf-of
))
169 ((iobuf-empty-p input-iobuf
)
170 (let ((nbytes (%buffer-fill buffer timeout
)))
171 (if (iobuf-empty-p input-iobuf
)
172 (if (eql :eof nbytes
) :eof
0)
173 (iobuf->vector input-iobuf vector start end
))))
175 (iobuf->vector input-iobuf vector start end
)))))
178 ;;;-------------------------------------------------------------------------
180 ;;;-------------------------------------------------------------------------
182 (defmethod device-write :around
((buffer buffer
) vector
183 &key
(start 0) end timeout
)
184 (check-bounds vector start end
)
187 (call-next-method buffer vector
:start start
188 :end end
:timeout timeout
)))
190 (defmethod device-write ((buffer single-channel-buffer
) vector
191 &key start end timeout
)
192 (with-synchronized-buffer (buffer :output
)
193 ;; If the previous operation was a read, flush the read buffer
194 ;; and reposition the file offset accordingly
195 (%buffer-clear-input buffer
)
196 (%buffer-write-vector buffer vector start end timeout
)))
198 (defmethod device-write ((buffer dual-channel-buffer
) vector
199 &key start end timeout
)
200 (with-synchronized-buffer (buffer :output
)
201 (%buffer-write-vector buffer vector start end timeout
)))
203 (defmethod %buffer-write-vector
((buffer buffer
) vector start end timeout
)
204 (with-accessors ((output-iobuf output-iobuf-of
))
206 (multiple-value-prog1
207 (vector->iobuf output-iobuf vector start end
)
208 (setf (last-io-op-of buffer
) :write
)
209 (when (iobuf-full-p output-iobuf
)
210 (%buffer-flush buffer timeout
)))))
213 ;;;-------------------------------------------------------------------------
215 ;;;-------------------------------------------------------------------------
217 (defmethod device-position ((buffer single-channel-buffer
))
218 (with-synchronized-buffer (buffer :input
)
219 (%buffer-position buffer
)))
221 (defun %buffer-position
(buffer)
222 (let ((position (device-position (device-of buffer
))))
223 (assert (not (null position
)) (position)
224 "A single-channel-buffer's device must not return a NULL device-position.")
225 (ecase (last-io-op-of buffer
)
227 (- position
(iobuf-available-octets (input-iobuf-of buffer
))))
229 (+ position
(iobuf-available-octets (output-iobuf-of buffer
)))))))
231 (defmethod (setf device-position
)
232 (position (buffer single-channel-buffer
) &optional
(from :start
))
233 (setf (%buffer-position buffer from
) position
))
235 (defun (setf %buffer-position
) (position buffer from
)
236 (setf (device-position (device-of buffer
) from
) position
))
239 ;;;-------------------------------------------------------------------------
241 ;;;-------------------------------------------------------------------------
243 (defmethod buffer-clear-input ((buffer single-channel-buffer
))
244 (with-synchronized-buffer (buffer :input
)
245 (%buffer-clear-input buffer
)))
247 (defmethod %buffer-clear-input
((buffer single-channel-buffer
))
248 (when (eql :read
(last-io-op-of buffer
))
249 (let ((nbytes (iobuf-available-octets (input-iobuf-of buffer
))))
250 (unless (zerop nbytes
)
251 (setf (%buffer-position buffer
:current
) (- nbytes
)))
252 (iobuf-reset (input-iobuf-of buffer
)))))
254 (defmethod buffer-clear-input ((buffer buffer
))
255 (with-synchronized-buffer (buffer :input
)
256 (%buffer-clear-input buffer
)))
258 (defmethod %buffer-clear-input
((buffer dual-channel-buffer
))
259 (iobuf-reset (input-iobuf-of buffer
)))
262 ;;;-------------------------------------------------------------------------
264 ;;;-------------------------------------------------------------------------
266 (defmethod buffer-clear-output ((buffer single-channel-buffer
))
267 (with-synchronized-buffer (buffer :output
)
268 (%buffer-clear-output buffer
)))
270 (defmethod %buffer-clear-output
((buffer single-channel-buffer
))
271 (when (eql :write
(last-io-op-of buffer
))
272 (iobuf-reset (output-iobuf-of buffer
))))
274 (defmethod buffer-clear-output ((buffer dual-channel-buffer
))
275 (with-synchronized-buffer (buffer :output
)
276 (iobuf-reset (output-iobuf-of buffer
))))
279 ;;;-------------------------------------------------------------------------
281 ;;;-------------------------------------------------------------------------
283 (defmethod buffer-fill ((buffer single-channel-buffer
) &key timeout
)
284 (with-synchronized-buffer (buffer :input
)
285 (%buffer-clear-output buffer
)
286 (%buffer-fill buffer timeout
)))
288 (defmethod buffer-fill ((buffer dual-channel-buffer
) &key timeout
)
289 (with-synchronized-buffer (buffer :input
)
290 (%buffer-fill buffer timeout
)))
292 (defmethod %buffer-fill
((buffer buffer
) timeout
)
293 (with-accessors ((device device-of
)
294 (input-iobuf input-iobuf-of
))
296 (multiple-value-bind (data start end
)
297 (iobuf-next-empty-zone input-iobuf
)
299 (device-read device data
:start start
300 :end end
:timeout timeout
)))
303 (error 'end-of-file
:stream buffer
))
305 (setf (iobuf-end input-iobuf
) (+ start nbytes
))
306 (setf (last-io-op-of buffer
) :read
)
307 (values nbytes
(iobuf-available-space input-iobuf
))))))))
310 ;;;-------------------------------------------------------------------------
312 ;;;-------------------------------------------------------------------------
314 (defmethod buffer-flush ((buffer single-channel-buffer
) &key timeout
)
315 (with-synchronized-buffer (buffer :output
)
316 (when (eql :write
(last-io-op-of buffer
))
317 (%buffer-flush buffer timeout
))))
319 (defmethod buffer-flush ((buffer dual-channel-buffer
) &key timeout
)
320 (with-synchronized-buffer (buffer :output
)
321 (%buffer-flush buffer timeout
)))
323 (defmethod %buffer-flush
((buffer buffer
) timeout
)
324 (with-accessors ((device device-of
)
325 (output-iobuf output-iobuf-of
))
327 (multiple-value-bind (data start end
)
328 (iobuf-next-data-zone output-iobuf
)
330 (device-write device data
:start start
331 :end end
:timeout timeout
)))
332 (setf (iobuf-start output-iobuf
) (+ start nbytes
))
333 (setf (last-io-op-of buffer
) :write
)
334 (iobuf-available-octets output-iobuf
)))))
337 ;;;-------------------------------------------------------------------------
339 ;;;-------------------------------------------------------------------------
341 (defmethod buffer-wait-until-flushable ((buffer buffer
) &key timeout
)
342 (device-poll-output (device-of buffer
) :timeout timeout
))