Completely rewrote the interface.
- Added SELECT! procedure. - Fixed bug in SELECT -- it was side-effecting its parameters.
This commit is contained in:
shivers
parent
80adbe0761
commit
e7460b6e74
|
|
@ -9,17 +9,35 @@
|
|||
/* Make sure foreign-function stubs interface to the C funs correctly: */
|
||||
#include "select1.h"
|
||||
|
||||
scheme_value df_scm_select(long nargs, scheme_value *args)
|
||||
scheme_value df_select_copyback(long nargs, scheme_value *args)
|
||||
{
|
||||
extern scheme_value scm_select(scheme_value , scheme_value , scheme_value , scheme_value , int *, int *, int *);
|
||||
extern scheme_value select_copyback(scheme_value , scheme_value , scheme_value , scheme_value , int *, int *, int *);
|
||||
scheme_value ret1;
|
||||
scheme_value r1;
|
||||
int r2;
|
||||
int r3;
|
||||
int r4;
|
||||
|
||||
cig_check_nargs(5, nargs, "scm_select");
|
||||
r1 = scm_select(args[4], args[3], args[2], args[1], &r2, &r3, &r4);
|
||||
cig_check_nargs(5, nargs, "select_copyback");
|
||||
r1 = select_copyback(args[4], args[3], args[2], args[1], &r2, &r3, &r4);
|
||||
ret1 = r1;
|
||||
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
|
||||
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
|
||||
VECTOR_REF(*args,2) = ENTER_FIXNUM(r4);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_select_filter(long nargs, scheme_value *args)
|
||||
{
|
||||
extern scheme_value select_filter(scheme_value , scheme_value , scheme_value , scheme_value , int *, int *, int *);
|
||||
scheme_value ret1;
|
||||
scheme_value r1;
|
||||
int r2;
|
||||
int r3;
|
||||
int r4;
|
||||
|
||||
cig_check_nargs(5, nargs, "select_filter");
|
||||
r1 = select_filter(args[4], args[3], args[2], args[1], &r2, &r3, &r4);
|
||||
ret1 = r1;
|
||||
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
|
||||
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
|
||||
|
|
|
|||
109
scsh/select.scm
109
scsh/select.scm
|
|
@ -11,15 +11,28 @@
|
|||
;;; 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 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/errno read-set write-set exception-set . maybe-timeout)
|
||||
|
||||
(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 (optional-arg maybe-timeout #f))
|
||||
(vec-ok? (lambda (v)
|
||||
(vector-every? (lambda (elt)
|
||||
|
|
@ -27,28 +40,25 @@
|
|||
(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)
|
||||
|
||||
(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 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 '#() '#() '#())))))))
|
||||
(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/errno
|
||||
(scm_select (vector-desc rvec)
|
||||
(vector-desc wvec)
|
||||
(vector-desc evec)
|
||||
(desc nsecs)) ; Integer or #f for infinity.
|
||||
(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
|
||||
|
|
@ -61,3 +71,48 @@
|
|||
((< 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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
/* Exports from select1.c. */
|
||||
|
||||
scheme_value scm_select(scheme_value rvec, scheme_value wvec,
|
||||
scheme_value evec, scheme_value nsecs,
|
||||
int *r_numrdy, int *w_numrdy, int *e_numrdy);
|
||||
scheme_value select_copyback(scheme_value rvec, scheme_value wvec,
|
||||
scheme_value evec, scheme_value nsecs,
|
||||
int *r_numrdy, int *w_numrdy, int *e_numrdy);
|
||||
|
||||
scheme_value select_filter(scheme_value rvec, scheme_value wvec,
|
||||
scheme_value evec, scheme_value nsecs,
|
||||
int *r_numrdy, int *w_numrdy, int *e_numrdy);
|
||||
|
|
|
|||
Loading…
Reference in New Issue