scsh-0.5/scsh/select.scm

59 lines
1.9 KiB
Scheme

;;; select(2) syscall for scsh. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; TIMEOUT is 0 for immediate, >0 for timeout, #f for infinite;
;;; default is #f.
;;; The sets are vectors of file descriptors & fd ports.
;;; You get three new vectors back.
(define (select read-set write-set exception-set . maybe-timeout)
(receive (errno rs ws es)
(apply select/errno read-set write-set exception-set maybe-timeout)
(if errno
(apply errno-error errno select read-set write-set exception-set
maybe-timeout)
(values rs ws es))))
(define (select/errno read-set write-set exception-set . maybe-timeout)
(let ((timeout (optional-arg maybe-timeout #f))
(vec-ok? (lambda (v)
(vector-every? (lambda (elt)
(or (and (integer? elt) (>= elt 0))
(fdport? elt)))
v))))
;; Type-check input vectors.
(check-arg vec-ok? read-set select/errno)
(check-arg vec-ok? write-set select/errno)
(check-arg vec-ok? exception-set select/errno)
(check-arg (lambda (x) (or (not x) (integer? x))) timeout select/errno)
(let lp ()
(receive (errno rsize wsize esize)
(%select/errno read-set write-set exception-set timeout)
(cond ((not errno)
(values errno
(vector-take read-set rsize)
(vector-take write-set wsize)
(vector-take exception-set esize)))
((= errno errno/intr) (lp))
(else (values errno '#() '#() '#())))))))
(define-foreign %select/errno
(scm_select (vector-desc rvec)
(vector-desc wvec)
(vector-desc evec)
(desc nsecs)) ; Integer or #f for infinity.
desc ; errno or #f
fixnum ; nread - number of hits in RVEC
fixnum ; nwrite - number of hits in WVEC
fixnum) ; nexcept - number of hits in EVEC
(define (vector-take vec nelts)
(let ((short (make-vector nelts)))
(do ((i (- nelts 1) (- i 1)))
((< i 0))
(vector-set! short i (vector-ref vec i)))
short))