Commit 17f26bc1a92fa5c2cbd2a71c44da7bb8b71c0571
2017-06-24T21:37:33
WIP select
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
diff --git a/cffi-unistd.lisp b/cffi-unistd.lisp
index 8083cf7..5f58f85 100644
--- a/cffi-unistd.lisp
+++ b/cffi-unistd.lisp
@@ -121,3 +121,108 @@ or number of bytes written otherwise."
(when (< r 0)
(error-errno "dup"))
r))
+
+;; Select
+
+(defcstruct fd-set
+ (fds-bits fd-mask :count #.(/ +fd-setsize+ +nfdbits+)))
+
+(defun fd-elt (fd)
+ (/ fd +nfdbits+))
+
+(defun fd-mask (fd)
+ (ash 1 (mod fd +nfdbits+)))
+
+(defmacro fds-bits (fd fd-set)
+ `(mem-aref (foreign-slot-value ,fd-set '(:struct fd-set)
+ 'fds-bits)
+ 'fd-mask (fd-elt ,fd)))
+
+(defun fd-clr (fd fd-set)
+ (setf (fds-bits fd fd-set)
+ (logand (fds-bits fd fd-set) (lognot (fd-mask fd)))))
+
+(defun fd-isset (fd fd-set)
+ (not (zerop (logand (fds-bits fd fd-set) (fd-mask fd)))))
+
+(defun fd-set (fd fd-set)
+ (setf (fds-bits fd fd-set)
+ (logior (fds-bits fd fd-set) (fd-mask fd))))
+
+(defun fd-zero (fd-set)
+ (dotimes (i (/ (foreign-type-size 'fd-set) (foreign-type-size 'fd-mask)))
+ (setf (mem-aref (foreign-slot-value fd-set '(:struct fd-set) 'fds-bits)
+ 'fd-mask i)
+ 0)))
+
+(defcstruct timeval
+ (tv-sec :long)
+ (tv-usec :long))
+
+(defcfun ("select" c-select) :int
+ (nfds :int)
+ (readfds (:pointer (:struct fd-set)))
+ (writefds (:pointer (:struct fd-set)))
+ (exceptfds (:pointer (:struct fd-set)))
+ (timeout (:pointer (:struct timeval))))
+
+(defun select (nfds readfds writefds exceptfds timeout)
+ (let ((r (c-select nfds readfds writefds exceptfds timeout)))
+ (when (< r 0)
+ (error-errno "select"))
+ r))
+
+(defun list-to-fd-set (list fd-set)
+ (fd-zero fd-set)
+ (dolist (fd list)
+ (fd-set fd fd-set)))
+
+(defun seconds-to-timeval (seconds tv)
+ (let ((sec (floor seconds)))
+ (setf (foreign-slot-value tv '(:struct timeval) 'tv-sec)
+ sec
+ (foreign-slot-value tv '(:struct timeval) 'tv-sec)
+ (floor (* (- seconds sec) 1000000)))))
+
+(defun fd-set-filter (list fd-set)
+ (let ((result ()))
+ (dolist (fd list)
+ (when (fd-isset fd fd-set)
+ (push fd result)))
+ result))
+
+(defmacro with-selected ((readfds &optional writefds exceptfds timeout)
+ (readfds-var writefds-var exceptfds-var)
+ &body body)
+ (let ((g-readfds (gensym "R-"))
+ (g-writefds (gensym "W-"))
+ (g-exceptfds (gensym "E-"))
+ (nfds (gensym "N-"))
+ (fd-set-read (gensym "FDS-R-"))
+ (fd-set-write (gensym "FDS-W-"))
+ (fd-set-except (gensym "FDS-E-"))
+ (tv (gensym "TV-")))
+ `(let ((,g-readfds ,readfds)
+ (,g-writefds ,writefds)
+ (,g-exceptfds ,exceptfds)
+ (,nfds 0))
+ (cffi:with-foreign-objects ((,fd-set-read (:struct fd-set))
+ (,fd-set-write (:struct fd-set))
+ (,fd-set-except (:struct fd-set))
+ (,tv (:struct timeval)))
+ (list-to-fd-set ,g-readfds ,fd-set-read)
+ (list-to-fd-set ,g-writefds ,fd-set-write)
+ (list-to-fd-set ,g-exceptfds ,fd-set-except)
+ (seconds-to-timeval ,timeout ,tv)
+ (dolist (fd ,g-readfds)
+ (when (< ,nfds fd) (setq ,nfds fd)))
+ (dolist (fd ,g-writefds)
+ (when (< ,nfds fd) (setq ,nfds fd)))
+ (dolist (fd ,g-exceptfds)
+ (when (< ,nfds fd) (setq ,nfds fd)))
+ (incf ,nfds)
+ (select ,nfds ,fd-set-read ,fd-set-write ,fd-set-except ,tv)
+ (let ((,readfds-var (fd-set-filter ,g-readfds ,fd-set-read))
+ (,writefds-var (fd-set-filter ,g-writefds ,fd-set-write))
+ (,exceptfds-var (fd-set-filter ,g-exceptfds ,fd-set-except)))
+ ,@body)))))
diff --git a/grovel-unistd.lisp b/grovel-unistd.lisp
index 5c2c8fb..1bc5657 100644
--- a/grovel-unistd.lisp
+++ b/grovel-unistd.lisp
@@ -45,3 +45,7 @@
(constant (+seek-end+ "SEEK_END"))
(constant (+seek-data+ "SEEK_DATA"))
(constant (+seek-hole+ "SEEK_HOLE"))
+
+(ctype fd-mask "fd_mask")
+(constant (+fd-setsize+ "FD_SETSIZE"))
+(constant (+nfdbits+ "NFDBITS"))
diff --git a/package.lisp b/package.lisp
index 9b54c96..fea0423 100644
--- a/package.lisp
+++ b/package.lisp
@@ -44,4 +44,22 @@
#:c-pipe
#:pipe
#:with-pipe
- #:dup))
+ #:dup
+ #:fd-set
+ #:fds-bits
+ #:fd-mask
+ #:+fd-setsize+
+ #:+nfdbits+
+ #:fd-elt
+ #:fd-clr
+ #:fd-isset
+ #:fd-set
+ #:fd-zero
+ #:timeval
+ #:tv-sec
+ #:tv-usec
+ #:select
+ #:list-to-fd-set
+ #:seconds-to-timeval
+ #:fd-set-filter
+ #:with-selected))