mirror of
https://github.com/Ponce/slackbuilds
synced 2024-10-22 22:27:28 +02:00
7009dc6a71
Signed-off-by: Robby Workman <rworkman@slackbuilds.org>
309 lines
9.8 KiB
Diff
309 lines
9.8 KiB
Diff
From http://code.call-cc.org/cgi-bin/gitweb.cgi?p=chicken-core.git;a=commitdiff;h=556108092774086b6c86c2e27daf3f740ffec091
|
|
|
|
--- chicken-4.8.0.3/chicken.h
|
|
+++ chicken-4.8.0.3/chicken.h
|
|
@@ -1668,6 +1668,7 @@
|
|
C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
|
|
C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
|
|
C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
|
|
+C_fctexport int C_fcall C_check_fd_ready(int fd) C_regparm;
|
|
C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
|
|
C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
|
|
C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
|
|
--- chicken-4.8.0.3/posixunix.scm
|
|
+++ chicken-4.8.0.3/posixunix.scm
|
|
@@ -493,16 +493,7 @@
|
|
"if(val == -1) C_return(0);"
|
|
"C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
|
|
|
|
-(define ##sys#file-select-one
|
|
- (foreign-lambda* int ([int fd])
|
|
- "fd_set in;"
|
|
- "struct timeval tm;"
|
|
- "FD_ZERO(&in);"
|
|
- "FD_SET(fd, &in);"
|
|
- "tm.tv_sec = tm.tv_usec = 0;"
|
|
- "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) C_return(-1);"
|
|
- "else C_return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
|
|
-
|
|
+(define ##sys#file-select-one (foreign-lambda int "C_check_fd_ready" int) )
|
|
|
|
;;; Lo-level I/O:
|
|
|
|
--- chicken-4.8.0.3/runtime.c
|
|
+++ chicken-4.8.0.3/runtime.c
|
|
@@ -60,6 +60,11 @@
|
|
# define EOVERFLOW 0
|
|
#endif
|
|
|
|
+/* TODO: Include sys/select.h? Windows doesn't seem to have it... */
|
|
+#ifdef HAVE_POSIX_POLL
|
|
+# include <poll.h>
|
|
+#endif
|
|
+
|
|
#if !defined(C_NONUNIX)
|
|
|
|
# include <sys/types.h>
|
|
@@ -4036,20 +4041,39 @@
|
|
return C_fix(n);
|
|
}
|
|
|
|
+/*
|
|
+ * TODO: Implement something for Windows that supports selecting on
|
|
+ * arbitrary fds (there, select() only works on network sockets and
|
|
+ * poll() is not available at all).
|
|
+ */
|
|
+C_regparm int C_fcall C_check_fd_ready(int fd)
|
|
+{
|
|
+#ifdef HAVE_POSIX_POLL
|
|
+ struct pollfd ps;
|
|
+ ps.fd = fd;
|
|
+ ps.events = POLLIN;
|
|
+ return poll(&ps, 1, 0);
|
|
+#else
|
|
+ fd_set in;
|
|
+ struct timeval tm;
|
|
+ int rv;
|
|
+ FD_ZERO(&in);
|
|
+ FD_SET(fd, &in);
|
|
+ tm.tv_sec = tm.tv_usec = 0;
|
|
+ rv = select(fd + 1, &in, NULL, NULL, &tm);
|
|
+ if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
|
|
+ return rv;
|
|
+#endif
|
|
+}
|
|
|
|
C_regparm C_word C_fcall C_char_ready_p(C_word port)
|
|
{
|
|
-#if !defined(C_NONUNIX)
|
|
- fd_set fs;
|
|
- struct timeval to;
|
|
- int fd = C_fileno(C_port_file(port));
|
|
-
|
|
- FD_ZERO(&fs);
|
|
- FD_SET(fd, &fs);
|
|
- to.tv_sec = to.tv_usec = 0;
|
|
- return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
|
|
-#else
|
|
+#if defined(C_NONUNIX)
|
|
+ /* The best we can currently do on Windows... */
|
|
return C_SCHEME_TRUE;
|
|
+#else
|
|
+ int fd = C_fileno(C_port_file(port));
|
|
+ return C_mk_bool(C_check_fd_ready(fd) == 1);
|
|
#endif
|
|
}
|
|
|
|
--- chicken-4.8.0.3/tcp.scm
|
|
+++ chicken-4.8.0.3/tcp.scm
|
|
@@ -46,6 +46,7 @@
|
|
# define fcntl(a, b, c) 0
|
|
# define EWOULDBLOCK 0
|
|
# define EINPROGRESS 0
|
|
+# define EAGAIN 0
|
|
# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \
|
|
getsockopt(socket, level, optname, (char *)optval, optlen)
|
|
#else
|
|
@@ -111,6 +112,7 @@
|
|
(define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
|
|
(define ##net#shutdown (foreign-lambda int "shutdown" int int))
|
|
(define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
|
|
+(define ##net#check-fd-ready (foreign-lambda int "C_check_fd_ready" int))
|
|
|
|
(define ##net#send
|
|
(foreign-lambda*
|
|
@@ -177,30 +179,6 @@
|
|
if((se = getservbyname(serv, proto)) == NULL) C_return(0);
|
|
else C_return(ntohs(se->s_port));") )
|
|
|
|
-(define ##net#select
|
|
- (foreign-lambda* int ((int fd))
|
|
- "fd_set in;
|
|
- struct timeval tm;
|
|
- int rv;
|
|
- FD_ZERO(&in);
|
|
- FD_SET(fd, &in);
|
|
- tm.tv_sec = tm.tv_usec = 0;
|
|
- rv = select(fd + 1, &in, NULL, NULL, &tm);
|
|
- if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
|
|
- C_return(rv);") )
|
|
-
|
|
-(define ##net#select-write
|
|
- (foreign-lambda* int ((int fd))
|
|
- "fd_set out;
|
|
- struct timeval tm;
|
|
- int rv;
|
|
- FD_ZERO(&out);
|
|
- FD_SET(fd, &out);
|
|
- tm.tv_sec = tm.tv_usec = 0;
|
|
- rv = select(fd + 1, NULL, &out, NULL, &tm);
|
|
- if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
|
|
- C_return(rv);") )
|
|
-
|
|
(define ##net#gethostaddr
|
|
(foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
|
|
"struct hostent *he = gethostbyname(host);"
|
|
@@ -212,13 +190,6 @@
|
|
"addr->sin_addr = *((struct in_addr *)he->h_addr);"
|
|
"C_return(1);") )
|
|
|
|
-(define (yield)
|
|
- (##sys#call-with-current-continuation
|
|
- (lambda (return)
|
|
- (let ((ct ##sys#current-thread))
|
|
- (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
|
|
- (##sys#schedule) ) ) ) )
|
|
-
|
|
(define ##net#parse-host
|
|
(let ((substring substring))
|
|
(lambda (host proto)
|
|
@@ -343,7 +314,9 @@
|
|
(outbufsize (tbs))
|
|
(outbuf (and outbufsize (fx> outbufsize 0) ""))
|
|
(tmr (tcp-read-timeout))
|
|
+ (dlr (and tmr (+ (current-milliseconds) tmr)))
|
|
(tmw (tcp-write-timeout))
|
|
+ (dlw (and tmw (+ (current-milliseconds) tmw)))
|
|
(read-input
|
|
(lambda ()
|
|
(let loop ()
|
|
@@ -351,12 +324,11 @@
|
|
(cond ((eq? -1 n)
|
|
(cond ((or (eq? errno _ewouldblock)
|
|
(eq? errno _eagain))
|
|
- (when tmr
|
|
- (##sys#thread-block-for-timeout!
|
|
- ##sys#current-thread
|
|
- (+ (current-milliseconds) tmr) ) )
|
|
+ (when dlr
|
|
+ (##sys#thread-block-for-timeout!
|
|
+ ##sys#current-thread dlr) )
|
|
(##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
|
|
- (yield)
|
|
+ (##sys#thread-yield!)
|
|
(when (##sys#slot ##sys#current-thread 13)
|
|
(##sys#signal-hook
|
|
#:network-timeout-error
|
|
@@ -386,7 +358,7 @@
|
|
c) ) )
|
|
(lambda ()
|
|
(or (fx< bufindex buflen)
|
|
- (let ((f (##net#select fd)))
|
|
+ (let ((f (##net#check-fd-ready fd)))
|
|
(when (eq? f -1)
|
|
(##sys#update-errno)
|
|
(##sys#signal-hook
|
|
@@ -469,12 +441,11 @@
|
|
(cond ((eq? -1 n)
|
|
(cond ((or (eq? errno _ewouldblock)
|
|
(eq? errno _eagain))
|
|
- (when tmw
|
|
+ (when dlw
|
|
(##sys#thread-block-for-timeout!
|
|
- ##sys#current-thread
|
|
- (+ (current-milliseconds) tmw) ) )
|
|
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
|
|
- (yield)
|
|
+ ##sys#current-thread dlw) )
|
|
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
|
|
+ (##sys#thread-yield!)
|
|
(when (##sys#slot ##sys#current-thread 13)
|
|
(##sys#signal-hook
|
|
#:network-timeout-error
|
|
@@ -528,38 +499,29 @@
|
|
|
|
(define (tcp-accept tcpl)
|
|
(##sys#check-structure tcpl 'tcp-listener)
|
|
- (let ((fd (##sys#slot tcpl 1))
|
|
- (tma (tcp-accept-timeout)))
|
|
+ (let* ((fd (##sys#slot tcpl 1))
|
|
+ (tma (tcp-accept-timeout))
|
|
+ (dla (and tma (+ tma (current-milliseconds)))))
|
|
(let loop ()
|
|
- (if (eq? 1 (##net#select fd))
|
|
- (let ((fd (##net#accept fd #f #f)))
|
|
- (cond ((not (eq? -1 fd)) (##net#io-ports fd))
|
|
- ((eq? errno _eintr)
|
|
- (##sys#dispatch-interrupt loop))
|
|
- (else
|
|
- (##sys#update-errno)
|
|
- (##sys#signal-hook
|
|
- #:network-error
|
|
- 'tcp-accept
|
|
- (##sys#string-append "could not accept from listener - " strerror)
|
|
- tcpl))))
|
|
- (begin
|
|
- (when tma
|
|
- (##sys#thread-block-for-timeout!
|
|
- ##sys#current-thread
|
|
- (+ (current-milliseconds) tma) ) )
|
|
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
|
|
- (yield)
|
|
- (when (##sys#slot ##sys#current-thread 13)
|
|
- (##sys#signal-hook
|
|
- #:network-timeout-error
|
|
- 'tcp-accept
|
|
- "accept operation timed out" tma fd) )
|
|
- (loop) ) ) ) ) )
|
|
+ (when dla
|
|
+ (##sys#thread-block-for-timeout! ##sys#current-thread dla) )
|
|
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
|
|
+ (##sys#thread-yield!)
|
|
+ (if (##sys#slot ##sys#current-thread 13)
|
|
+ (##sys#signal-hook
|
|
+ #:network-timeout-error
|
|
+ 'tcp-accept
|
|
+ "accept operation timed out" tma fd) )
|
|
+ (let ((fd (##net#accept fd #f #f)))
|
|
+ (cond ((not (eq? -1 fd)) (##net#io-ports fd))
|
|
+ ((eq? errno _eintr)
|
|
+ (##sys#dispatch-interrupt loop))
|
|
+ (else
|
|
+ (network-error 'tcp-accept "could not accept from listener" tcpl)))) ) ) )
|
|
|
|
(define (tcp-accept-ready? tcpl)
|
|
(##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
|
|
- (let ((f (##net#select (##sys#slot tcpl 1))))
|
|
+ (let ((f (##net#check-fd-ready (##sys#slot tcpl 1))))
|
|
(when (eq? -1 f)
|
|
(##sys#update-errno)
|
|
(##sys#signal-hook
|
|
@@ -578,8 +540,9 @@
|
|
(define general-strerror (foreign-lambda c-string "strerror" int))
|
|
|
|
(define (tcp-connect host . more)
|
|
- (let ((port (optional more #f))
|
|
- (tmc (tcp-connect-timeout)))
|
|
+ (let* ((port (optional more #f))
|
|
+ (tmc (tcp-connect-timeout))
|
|
+ (dlc (and tmc (+ (current-milliseconds) tmc))))
|
|
(##sys#check-string host)
|
|
(unless port
|
|
(set!-values (host port) (##net#parse-host host "tcp"))
|
|
@@ -606,23 +569,9 @@
|
|
(let loop ()
|
|
(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
|
|
(cond ((eq? errno _einprogress)
|
|
- (let loop2 ()
|
|
- (let ((f (##net#select-write s)))
|
|
- (when (eq? f -1) (fail))
|
|
- (unless (eq? f 1)
|
|
- (when tmc
|
|
- (##sys#thread-block-for-timeout!
|
|
- ##sys#current-thread
|
|
- (+ (current-milliseconds) tmc) ) )
|
|
- (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
|
|
- (yield)
|
|
- (when (##sys#slot ##sys#current-thread 13)
|
|
- (##net#close s)
|
|
- (##sys#signal-hook
|
|
- #:network-timeout-error
|
|
- 'tcp-connect
|
|
- "connect operation timed out" tmc s) )
|
|
- (loop2) ) ) ))
|
|
+ (when dlc
|
|
+ (##sys#thread-block-for-timeout! ##sys#current-thread dlc))
|
|
+ (##sys#thread-block-for-i/o! ##sys#current-thread s #:all))
|
|
((eq? errno _eintr)
|
|
(##sys#dispatch-interrupt loop))
|
|
(else (fail) ) )))
|