>From 291ee9c7d86e56e7e591bf55dd6f4333a663ef55 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Thu, 18 Apr 2013 00:31:08 +0200 Subject: [PATCH 3/3] Implement file-select in terms of POSIX poll() for UNIX --- posixunix.scm | 116 +++++++++++++++++++++++++++------------------------------- 1 file changed, 54 insertions(+), 62 deletions(-) diff --git a/posixunix.scm b/posixunix.scm index b72ee52..02f0a5e 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -67,6 +67,7 @@ static C_TLS int C_wait_status; #endif #include +#include #include #ifndef O_FSYNC @@ -136,7 +137,6 @@ static C_TLS struct { static C_TLS int C_pipefds[ 2 ]; static C_TLS time_t C_secs; static C_TLS struct tm C_tm; -static C_TLS fd_set C_fd_sets[ 2 ]; static C_TLS struct timeval C_timeval; static C_TLS char C_hostbuf[ 256 ]; static C_TLS struct stat C_statbuf; @@ -303,13 +303,6 @@ static C_TLS sigset_t C_sigset; #define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w))) #define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w))) -#define C_zero_fd_set(i) FD_ZERO(&C_fd_sets[ i ]) -#define C_set_fd_set(i, fd) FD_SET(fd, &C_fd_sets[ i ]) -#define C_test_fd_set(i, fd) FD_ISSET(fd, &C_fd_sets[ i ]) -#define C_C_select(m) C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL)) -#define C_C_select_t(m, t) (C_set_timeval(t, &C_timeval), \ - C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval))) - #define C_ctime(n) (C_secs = (n), ctime(&C_secs)) #if defined(__SVR4) || defined(C_MACOSX) @@ -647,60 +640,59 @@ EOF ;;; I/O multiplexing: -(define file-select - (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)] - [fd_set (foreign-lambda void "C_set_fd_set" int int)] - [fd_test (foreign-lambda bool "C_test_fd_set" int int)] ) - (lambda (fdsr fdsw . timeout) - (let ([fdmax 0] - [tm (if (pair? timeout) (car timeout) #f)] ) - (fd_zero 0) - (fd_zero 1) - (cond [(not fdsr)] - [(fixnum? fdsr) - (set! fdmax fdsr) - (fd_set 0 fdsr) ] - [else - (##sys#check-list fdsr 'file-select) - (for-each - (lambda (fd) - (##sys#check-exact fd 'file-select) - (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd)) - (fd_set 0 fd) ) - fdsr) ] ) - (cond [(not fdsw)] - [(fixnum? fdsw) - (set! fdmax fdsw) - (fd_set 1 fdsw) ] - [else - (##sys#check-list fdsw 'file-select) - (for-each - (lambda (fd) - (##sys#check-exact fd 'file-select) - (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd)) - (fd_set 1 fd) ) - fdsw) ] ) - (let ([n (cond [tm - (##sys#check-number tm 'file-select) - (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ] - [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] ) - (cond [(fx< n 0) - (posix-error #:file-error 'file-select "failed" fdsr fdsw) ] - [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))] - [else - (values - (and fdsr - (if (fixnum? fdsr) - (fd_test 0 fdsr) - (let ([lstr '()]) - (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr) - lstr) ) ) - (and fdsw - (if (fixnum? fdsw) - (fd_test 1 fdsw) - (let ([lstw '()]) - (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw) - lstw) ) ) ) ] ) ) ) ) ) ) +(define (file-select fdsr fdsw . timeout) + (let* ((tm (if (pair? timeout) (car timeout) #f)) + (fdsrl (cond ((not fdsr) '()) + ((fixnum? fdsr) (list fdsr)) + (else (##sys#check-list fdsr 'file-select) + fdsr))) + (fdswl (cond ((not fdsw) '()) + ((fixnum? fdsw) (list fdsw)) + (else (##sys#check-list fdsw 'file-select) + fdsw))) + (nfdsr (##sys#length fdsrl)) + (nfdsw (##sys#length fdswl)) + (nfds (fx+ nfdsr nfdsw)) + (fds-blob (##sys#make-blob + (fx* nfds (foreign-value "sizeof(struct pollfd)" int))))) + (when tm (##sys#check-number tm)) + (do ((i 0 (fx+ i 1)) + (fdsrl fdsrl (cdr fdsrl))) + ((null? fdsrl)) + ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p)) + "struct pollfd *fds = p;" + "fds[i].fd = fd; fds[i].events = POLLIN;") i (car fdsrl) fds-blob)) + (do ((i nfdsr (fx+ i 1)) + (fdswl fdswl (cdr fdswl))) + ((null? fdswl)) + ((foreign-lambda* void ((int i) (int fd) (scheme-pointer p)) + "struct pollfd *fds = p;" + "fds[i].fd = fd; fds[i].events = POLLOUT;") i (car fdswl) fds-blob)) + (let ((n ((foreign-lambda int "poll" scheme-pointer int int) + fds-blob nfds (if tm (inexact->exact (* (max 0 tm) 1000)) -1)))) + (cond ((fx< n 0) + (posix-error #:file-error 'file-select "failed" fdsr fdsw) ) + ((fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))) + (else + (let ((rl (let lp ((i 0) (res '()) (fds fdsrl)) + (cond ((null? fds) (##sys#fast-reverse res)) + (((foreign-lambda* bool ((int i) (scheme-pointer p)) + "struct pollfd *fds = p;" + "C_return(fds[i].revents & (POLLIN|POLLERR|POLLHUP|POLLNVAL));") + i fds-blob) + (lp (fx+ i 1) (cons (car fds) res) (cdr fds))) + (else (lp (fx+ i 1) res (cdr fds)))))) + (wl (let lp ((i nfdsr) (res '()) (fds fdswl)) + (cond ((null? fds) (##sys#fast-reverse res)) + (((foreign-lambda* bool ((int i) (scheme-pointer p)) + "struct pollfd *fds = p;" + "C_return(fds[i].revents & (POLLOUT|POLLERR|POLLHUP|POLLNVAL));") + i fds-blob) + (lp (fx+ i 1) (cons (car fds) res) (cdr fds))) + (else (lp (fx+ i 1) res (cdr fds))))))) + (values + (and fdsr (if (fixnum? fdsr) (and (memq fdsr rl) fdsr) rl)) + (and fdsw (if (fixnum? fdsw) (and (memq fdsw wl) fdsw) wl))))))))) ;;; File attribute access: -- 1.8.0.1