scsh-0.5/scsh/select.scm

119 lines
3.8 KiB
Scheme
Raw Normal View History

1995-10-13 23:34:21 -04:00
;;; select(2) syscall for scsh. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
(foreign-source
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
"#include \"select1.h\""
"" "")
1995-10-13 23:34:21 -04:00
;;; 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-vec write-vec exception-vec . maybe-timeout)
(let ((rv (copy-vector read-vec))
(wv (copy-vector write-vec))
(ev (copy-vector exception-vec)))
(receive (nr nw ne) (apply select!/copyback rv wv ev maybe-timeout)
(values (vector-take rv nr)
(vector-take wv nw)
(vector-take ev ne)))))
(define (select!/copyback read-vec write-vec exception-vec . maybe-timeout)
(receive (errno nr nw ne)
(apply select!/copyback/errno read-vec write-vec exception-vec
maybe-timeout)
1995-10-13 23:34:21 -04:00
(if errno
(apply errno-error errno select!/copyback
read-vec write-vec exception-vec maybe-timeout)
(values nr nw ne))))
1995-10-13 23:34:21 -04:00
(define (select!/copyback/errno read-vec write-vec
exception-vec . maybe-timeout)
1995-10-13 23:34:21 -04:00
(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-vec select!/copyback/errno)
(check-arg vec-ok? write-vec select!/copyback/errno)
(check-arg vec-ok? exception-vec select!/copyback/errno)
(check-arg (lambda (x) (or (not x) (integer? x))) timeout
select!/copyback/errno)
1995-10-13 23:34:21 -04:00
(let lp ()
(receive (errno nr nw ne)
(%select/copyback/errno read-vec write-vec exception-vec timeout)
(if (and errno (= errno errno/intr)) ; Retry on interrupts.
(lp)
(values errno nr nw ne))))))
(define-foreign %select/copyback/errno
(select_copyback (vector-desc rvec)
(vector-desc wvec)
(vector-desc evec)
(desc nsecs)) ; Integer or #f for infinity.
1995-10-13 23:34:21 -04:00
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))
;;; SELECT!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The side-effecting variant. To be documented.
(define (select! read-vec write-vec exception-vec . maybe-timeout)
(receive (errno nr nw ne)
(apply select!/errno read-vec write-vec exception-vec maybe-timeout)
(if errno
(apply errno-error errno select! read-vec write-vec exception-vec
maybe-timeout)
(values nr nw ne))))
(define (select!/errno read-vec write-vec exception-vec . maybe-timeout)
(let ((timeout (optional-arg maybe-timeout #f))
(vec-ok? (lambda (v)
(vector-every? (lambda (elt)
(or (and (integer? elt) (>= elt 0))
(not elt)
(fdport? elt)))
v))))
;; Type-check input vectors.
(check-arg vec-ok? read-vec select!/errno)
(check-arg vec-ok? write-vec select!/errno)
(check-arg vec-ok? exception-vec select!/errno)
(check-arg (lambda (x) (or (not x) (integer? x))) timeout select!/errno)
(let lp ()
(receive (errno nr nw ne)
(%select!/errno read-vec write-vec exception-vec timeout)
(if (and errno (= errno errno/intr)) ; Retry on interrupts.
(lp)
(values errno nr nw ne))))))
(define-foreign %select!/errno
(select_filter (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