From 81d3a52b23706824bc6010d3f50326a5b3643729 Mon Sep 17 00:00:00 2001 From: Erik Falor Date: Sun, 8 Jun 2014 03:24:17 +0700 Subject: development/chicken: Updated for version 4.9.0. Signed-off-by: Willy Sudiarto Raharjo --- development/chicken/chicken.SlackBuild | 22 +- development/chicken/chicken.info | 6 +- .../chicken/patches/01_all_CVE-2013-1874.patch | 25 -- .../chicken/patches/02_all_CVE-2013-2024.patch | 47 ---- .../chicken/patches/03_all_CVE-2013-2075_1.patch | 161 ----------- .../chicken/patches/04_all_CVE-2013-2075_2.patch | 309 --------------------- 6 files changed, 6 insertions(+), 564 deletions(-) delete mode 100644 development/chicken/patches/01_all_CVE-2013-1874.patch delete mode 100644 development/chicken/patches/02_all_CVE-2013-2024.patch delete mode 100644 development/chicken/patches/03_all_CVE-2013-2075_1.patch delete mode 100644 development/chicken/patches/04_all_CVE-2013-2075_2.patch (limited to 'development') diff --git a/development/chicken/chicken.SlackBuild b/development/chicken/chicken.SlackBuild index b540cc37ef..d706176b38 100644 --- a/development/chicken/chicken.SlackBuild +++ b/development/chicken/chicken.SlackBuild @@ -2,7 +2,7 @@ # Slackware build script for Chicken Scheme -# Written by Erik Falor (ewfalor@gmail.com) +# Written by Erik Falor (ewfalor@gmail.com) 2014 # All rights reserved. # # Redistribution and use of this script, with or without modification, is @@ -23,7 +23,7 @@ # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PRGNAM=chicken -VERSION=${VERSION:-4.8.0.5} +VERSION=${VERSION:-4.9.0} BUILD=${BUILD:-1} TAG=${TAG:-_SBo} @@ -75,29 +75,13 @@ for f in defaults.make Makefile.linux rules.make sed "s,ARCH,zARCH," -i ${f} done -# Due to the way Chicken generates C code from Scheme sources, it is expensive -# to apply a patch to the generated C files. Instead, we first build an -# unpatched bootstrap Chicken compiler - this will allow us to apply the -# security patches to the Scheme source code of Chicken itself, allowing us to -# rebuild Chicken from scratch. - -make boot-chicken \ - C_COMPILER_OPTIMIZATION_OPTIONS="$SLKCFLAGS" \ - PLATFORM=linux - -# Apply the security patches to Chicken's Scheme sources -for P in $CWD/patches/* ; do patch -p1 -i $P ; done - -# Build Chicken anew using the bootstrapping compiler to generate new C files -# from our patched code make \ C_COMPILER_OPTIMIZATION_OPTIONS="$SLKCFLAGS" \ PLATFORM=linux \ PREFIX=/usr \ LIBDIR=/usr/lib${LIBDIRSUFFIX} \ TOPMANDIR=/usr/man \ - DOCDIR=/usr/doc/$PRGNAM-$VERSION \ - CHICKEN=./chicken-boot + DOCDIR=/usr/doc/$PRGNAM-$VERSION make install \ C_COMPILER_OPTIMIZATION_OPTIONS="$SLKCFLAGS" \ diff --git a/development/chicken/chicken.info b/development/chicken/chicken.info index d6b9b38439..938b2ed5bc 100644 --- a/development/chicken/chicken.info +++ b/development/chicken/chicken.info @@ -1,8 +1,8 @@ PRGNAM="chicken" -VERSION="4.8.0.5" +VERSION="4.9.0" HOMEPAGE="http://wiki.call-cc.org" -DOWNLOAD="http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz" -MD5SUM="a63d8a0b6bc58a97ec5cc4c4a19b308a" +DOWNLOAD="http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.tar.gz" +MD5SUM="be20b9735be86ab557cc8bf0887699dc" DOWNLOAD_x86_64="" MD5SUM_x86_64="" REQUIRES="" diff --git a/development/chicken/patches/01_all_CVE-2013-1874.patch b/development/chicken/patches/01_all_CVE-2013-1874.patch deleted file mode 100644 index 599ae61d32..0000000000 --- a/development/chicken/patches/01_all_CVE-2013-1874.patch +++ /dev/null @@ -1,25 +0,0 @@ -From http://lists.nongnu.org/archive/html/chicken-hackers/2013-03/msg00074.html ---- chicken-4.8.0.3/csi.scm -+++ chicken-4.8.0.3/csi.scm -@@ -1019,13 +1019,11 @@ EOF - (cons (cadr p) (loop (cddr p)))) ) ] - [else '()] ) ) ) - (define (loadinit) -- (let ([fn (##sys#string-append "./" init-file)]) -- (if (file-exists? fn) -- (load fn) -- (let* ([prefix (chop-separator (or (get-environment-variable "HOME") "."))] -- [fn (string-append prefix "/" init-file)] ) -- (when (file-exists? fn) -- (load fn) ) ) ) ) ) -+ (and-let* ((home (get-environment-variable "HOME")) -+ ((not (string=? home "")))) -+ (let ((fn (string-append (chop-separator home) "/" init-file))) -+ (when (file-exists? fn) -+ (load fn) ) ) ) ) - (define (evalstring str #!optional (rec (lambda _ (void)))) - (let ((in (open-input-string str))) - (do ([x (read in) (read in)]) --- -1.7.12 - diff --git a/development/chicken/patches/02_all_CVE-2013-2024.patch b/development/chicken/patches/02_all_CVE-2013-2024.patch deleted file mode 100644 index d57a4bce97..0000000000 --- a/development/chicken/patches/02_all_CVE-2013-2024.patch +++ /dev/null @@ -1,47 +0,0 @@ -From http://code.call-cc.org/cgi-bin/gitweb.cgi?p=chicken-core.git;a=commit;h=58684f69572453acc6fed7326fa9df39be98760e ---- chicken-4.8.0.3/setup-api.scm -+++ chicken-4.8.0.3/setup-api.scm -@@ -239,7 +239,7 @@ - (cond ((string=? prg "csc") - (string-intersperse - (cons* -- (shellpath (find-program "csc")) -+ (find-program "csc") - "-feature" "compiling-extension" - (if (or (deployment-mode) - (and (feature? #:cross-chicken) ---- chicken-4.8.0.3/utils.scm -+++ chicken-4.8.0.3/utils.scm -@@ -59,20 +59,18 @@ - ;;; Quote string for shell - - (define (qs str #!optional (platform (build-platform))) -- (case platform -- ((mingw32) -- (string-append "\"" str "\"")) -- (else -- (if (zero? (string-length str)) -- "''" -- (string-concatenate -- (map (lambda (c) -- (if (or (char-whitespace? c) -- (memq c '(#\# #\" #\' #\` #\´ #\~ #\& #\% #\$ #\! #\* #\; -- #\< #\> #\\ #\( #\) #\[ #\] #\{ #\} #\?))) -- (string #\\ c) -- (string c))) -- (string->list str))))))) -+ (let ((delim (if (eq? platform 'mingw32) #\" #\')) -+ (escaped (if (eq? platform 'mingw32) "\"\"" "'\\''"))) -+ (string-append -+ (string delim) -+ (string-concatenate -+ (map (lambda (c) -+ (cond -+ ((char=? c delim) escaped) -+ ((char=? c #\nul) (error 'qs "NUL character can not be represented in shell string" str)) -+ (else (string c)))) -+ (string->list str))) -+ (string delim)))) - - - ;;; Compile and load file diff --git a/development/chicken/patches/03_all_CVE-2013-2075_1.patch b/development/chicken/patches/03_all_CVE-2013-2075_1.patch deleted file mode 100644 index d3de47bb6e..0000000000 --- a/development/chicken/patches/03_all_CVE-2013-2075_1.patch +++ /dev/null @@ -1,161 +0,0 @@ -From 9e2022652258e8a30e5cedbf0abc9cd85a0f6af7 Mon Sep 17 00:00:00 2001 -From: Peter Bex -Date: Thu, 18 Apr 2013 00:31:08 +0200 -Subject: [PATCH] Implement file-select in terms of POSIX poll() for UNIX - -Signed-off-by: felix ---- - posixunix.scm | 116 ++++++++++++++++++++++++++------------------------------ - 1 files changed, 54 insertions(+), 62 deletions(-) - -diff --git a/posixunix.scm b/posixunix.scm -index 15cb535..90e0176 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) -@@ -656,60 +649,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.7.2.1 - diff --git a/development/chicken/patches/04_all_CVE-2013-2075_2.patch b/development/chicken/patches/04_all_CVE-2013-2075_2.patch deleted file mode 100644 index b85ea7c8b2..0000000000 --- a/development/chicken/patches/04_all_CVE-2013-2075_2.patch +++ /dev/null @@ -1,309 +0,0 @@ -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 -+#endif -+ - #if !defined(C_NONUNIX) - - # include -@@ -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) ) ))) -- cgit v1.2.3