194 lines
6.3 KiB
Scheme
194 lines
6.3 KiB
Scheme
;;; select(2) syscall for scsh. -*- Scheme -*-
|
|
;;; Copyright (c) 1995 by Olin Shivers.
|
|
|
|
(foreign-init-name "select")
|
|
|
|
|
|
(foreign-source
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"select1.h\""
|
|
"" "")
|
|
|
|
;;; 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.
|
|
|
|
; The following routines copy ports to fd's, and copy fd's back to fd's and
|
|
; ports, so that select can take numbers and ports, simultaneously.
|
|
|
|
; This is a C procedure in scheme. So sue me. At least it's tail-recursive
|
|
(define (fd-filter filter-me)
|
|
(let* ((len (vector-length filter-me))
|
|
(vector-to-return (make-vector len)))
|
|
(let loop ((count (- len 1)))
|
|
(if (>= count 0)
|
|
(let ((ref (vector-ref filter-me count)))
|
|
(if (integer? ref)
|
|
(vector-set! vector-to-return count ref)
|
|
(vector-set! vector-to-return count (port->fdes ref)))
|
|
(loop (- count 1)))))
|
|
vector-to-return))
|
|
|
|
; ! means side-effect, the next one is more functional.
|
|
(define (fd-copyback! orig form)
|
|
(let loop ((count (- (vector-length orig) 1)))
|
|
(if (>= count 0)
|
|
(begin
|
|
(if (not (vector-ref form count))
|
|
(vector-set! orig count #f)
|
|
(vector-set! form count (vector-ref orig count)))
|
|
(loop (- count 1)))))
|
|
orig)
|
|
|
|
(define (fd-copyback orig form)
|
|
(let* ((len (vector-length orig))
|
|
(vector-to-return (make-vector len #f)))
|
|
(let loop ((count (- len 1)))
|
|
(if (>= count 0)
|
|
(begin
|
|
(if (vector-ref form count)
|
|
(vector-set! vector-to-return count (vector-ref orig count)))
|
|
(loop (- count 1)))))
|
|
vector-to-return))
|
|
|
|
(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! rv wv ev maybe-timeout)
|
|
(values (vector-take-form read-vec rv nr)
|
|
(vector-take-form write-vec wv nw)
|
|
(vector-take-form exception-vec 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)
|
|
(if errno
|
|
(apply errno-error errno select!/copyback
|
|
read-vec write-vec exception-vec maybe-timeout)
|
|
(values nr nw ne))))
|
|
|
|
|
|
(define (select!/copyback/errno read-vec write-vec
|
|
exception-vec . maybe-timeout)
|
|
(let ((timeout (and (pair? maybe-timeout)
|
|
(if (pair? (cdr maybe-timeout))
|
|
(apply error "Too many arguments"
|
|
select!/copyback/errno
|
|
read-vec write-vec exception-vec
|
|
maybe-timeout)
|
|
(real->exact-integer (check-arg real?
|
|
(car maybe-timeout)
|
|
select!/copyback/errno)))))
|
|
|
|
(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)
|
|
|
|
(let ((prop-read-vec (fd-filter read-vec))
|
|
(prop-write-vec (fd-filter write-vec))
|
|
(prop-exception-vec (fd-filter exception-vec)))
|
|
(let lp ()
|
|
(receive (errno nr nw ne)
|
|
(%select/copyback/errno prop-read-vec prop-write-vec prop-exception-vec timeout)
|
|
(if (and errno (= errno errno/intr)) ; Retry on interrupts.
|
|
(lp)
|
|
(values errno
|
|
(fd-copyback read-vec nr)
|
|
(fd-copyback write-vec nw)
|
|
(fd-copyback exception-vec ne))))))))
|
|
|
|
|
|
(define-foreign %select/copyback/errno
|
|
(select_copyback (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-form vec form nelts)
|
|
(let ((short (make-vector nelts)))
|
|
(do ((i (- (vector-length vec) 1) (- i 1)))
|
|
((< i 0))
|
|
(if (vector-ref form i)
|
|
(begin
|
|
(set! nelts (- nelts 1))
|
|
(vector-set! short nelts (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 (and (pair? maybe-timeout)
|
|
(if (pair? (cdr maybe-timeout))
|
|
(apply error "Too many arguments"
|
|
select!/copyback/errno
|
|
read-vec write-vec exception-vec
|
|
maybe-timeout)
|
|
(real->exact-integer (check-arg real?
|
|
(car maybe-timeout)
|
|
select!/copyback/errno)))))
|
|
|
|
(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 ((prop-read-vec (fd-filter read-vec))
|
|
(prop-write-vec (fd-filter write-vec))
|
|
(prop-exception-vec (fd-filter exception-vec)))
|
|
(let lp ()
|
|
(receive (errno nr nw ne)
|
|
(%select!/errno prop-read-vec prop-write-vec prop-exception-vec timeout)
|
|
(if (and errno (= errno errno/intr)) ; Retry on interrupts.
|
|
(lp)
|
|
(begin
|
|
(fd-copyback! read-vec prop-read-vec)
|
|
(fd-copyback! write-vec prop-write-vec)
|
|
(fd-copyback! exception-vec prop-exception-vec)
|
|
(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
|