1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Device common functions.
6 (in-package :io.zeta-streams
)
8 ;;;-------------------------------------------------------------------------
10 ;;;-------------------------------------------------------------------------
13 ((handle :initarg
:handle
:accessor handle-of
)
14 (readable :initarg
:readable
:accessor device-readablep
)
15 (writeable :initarg
:writeable
:accessor device-writeablep
)
16 (seekable :initarg
:seekable
:accessor device-seekablep
)))
18 (defclass direct-device
(device) ())
20 (defclass memory-buffer-device
(direct-device) ())
23 ;;;-------------------------------------------------------------------------
24 ;;; Relinquish I/O resources
25 ;;;-------------------------------------------------------------------------
27 (defgeneric relinquish
(device &rest args
&key abort
))
30 ;;;-------------------------------------------------------------------------
32 ;;;-------------------------------------------------------------------------
34 (defgeneric device-read
(device vector
&key start end timeout
))
36 (defgeneric device-write
(device vector
&key start end timeout
))
38 (defgeneric device-position
(device))
40 (defgeneric (setf device-position
) (position device
&optional from
))
42 (defgeneric device-length
(device))
44 (defgeneric device-poll-input
(device &key timeout
))
46 (defgeneric device-poll-output
(device &key timeout
))
48 ;;; Internal functions
50 (defgeneric device-open
(device &rest initargs
))
52 (defgeneric device-read
/non-blocking
(device vector start end
))
54 (defgeneric device-read
/timeout
(device vector start end timeout
))
56 (defgeneric device-write
/non-blocking
(device vector start end
))
58 (defgeneric device-write
/timeout
(device vector start end timeout
))
61 ;;;-------------------------------------------------------------------------
63 ;;;-------------------------------------------------------------------------
65 (defmacro with-device
((name) &body body
)
66 `(let ((*device
* ,name
))
67 (declare (special *device
*))
71 ;;;-------------------------------------------------------------------------
72 ;;; Default no-op methods
73 ;;;-------------------------------------------------------------------------
75 (defmethod device-position ((device device
))
78 (defmethod (setf device-position
) (position (device device
) &optional from
)
79 (declare (ignore position from
))
82 (defmethod device-length ((device device
))
86 ;;;-------------------------------------------------------------------------
87 ;;; Default DEVICE-READ
88 ;;;-------------------------------------------------------------------------
90 (defmethod device-read :around
((device device
) vector
&key
91 (start 0) end timeout
)
92 (check-bounds vector start end
)
95 (call-next-method device vector
:start start
96 :end end
:timeout timeout
)))
98 (defmethod device-read ((device device
) vector
&key start end timeout
)
99 (if (and timeout
(zerop timeout
))
100 (device-read/non-blocking device vector start end
)
101 (device-read/timeout device vector start end timeout
)))
104 ;;;-------------------------------------------------------------------------
105 ;;; Default DEVICE-WRITE
106 ;;;-------------------------------------------------------------------------
108 (defmethod device-write :around
((device device
) vector
&key
109 (start 0) end timeout
)
110 (check-bounds vector start end
)
113 (call-next-method device vector
:start start
114 :end end
:timeout timeout
)))
116 (defmethod device-write ((device device
) vector
&key start end timeout
)
117 (if (and timeout
(zerop timeout
))
118 (device-write/non-blocking device vector start end
)
119 (device-write/timeout device vector start end timeout
)))