hollalinux
/
slackbuilds
mirror of https://github.com/SlackBuildsOrg/slackbuilds.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

development/chicken: Updated for version 4.8.0.4. 

Signed-off-by: Robby Workman <rworkman@slackbuilds.org>
This commit is contained in:
Erik Falor 2013-10-26 18:54:28 -05:00 committed by Robby Workman
parent 21963f3ca7
commit 7009dc6a71
8 changed files with 572 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
development/chicken/README
View File

@ -1,4 +1,4 @@
chicken is a compiler that translates Scheme source files into C,
Chicken is a compiler that translates Scheme source files into C,
which in turn can be fed to a C compiler to generate a standalone
executable. An interpreter is also available and can be used as a
scripting environment or for test programs before compilation.

27
development/chicken/chicken.SlackBuild
View File

@ -1,12 +1,12 @@
#!/bin/sh
# Slackware build script for Chicken
# Slackware build script for Chicken Scheme
# Written by Patrick Pippen (dabittweiler@gmail.com)
# Written by Erik Falor (ewfalor@gmail.com)
PRGNAM=chicken
VERSION=${VERSION:-4.6.0}
BUILD=${BUILD:-2}
VERSION=${VERSION:-4.8.0.4}
BUILD=${BUILD:-1}
TAG=${TAG:-_SBo}
# Automatically determine the architecture we're building on:
@ -59,13 +59,30 @@ 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 \
PREFIX=/usr
# 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
DOCDIR=/usr/doc/$PRGNAM-$VERSION \
CHICKEN=./chicken-boot
make install \
C_COMPILER_OPTIMIZATION_OPTIONS="$SLKCFLAGS" \

10
development/chicken/chicken.info
View File

@ -1,10 +1,10 @@
PRGNAM="chicken"
VERSION="4.6.0"
VERSION="4.8.0.4"
HOMEPAGE="http://wiki.call-cc.org"
DOWNLOAD="http://code.call-cc.org/releases/4.6.0/chicken-4.6.0.tar.gz"
MD5SUM="538a93e786e550ad848a040bcd902184"
DOWNLOAD="http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz"
MD5SUM="71621afa6a39df98d011db08c76e2fa0"
DOWNLOAD_x86_64=""
MD5SUM_x86_64=""
REQUIRES=""
MAINTAINER="Patrick Pippen"
EMAIL="dabittweiler@gmail.com"
MAINTAINER="Erik Falor"
EMAIL="ewfalor@gmail.com"

25
development/chicken/patches/01_all_CVE-2013-1874.patch Normal file
View File

@ -0,0 +1,25 @@
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

47
development/chicken/patches/02_all_CVE-2013-2024.patch Normal file
View File

@ -0,0 +1,47 @@
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

161
development/chicken/patches/03_all_CVE-2013-2075_1.patch Normal file
View File

@ -0,0 +1,161 @@
From 9e2022652258e8a30e5cedbf0abc9cd85a0f6af7 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter.bex@xs4all.nl>
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 <felix@call-with-current-continuation.org>
---
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 <sys/mman.h>
+#include <sys/poll.h>
#include <time.h>
#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

309
development/chicken/patches/04_all_CVE-2013-2075_2.patch Normal file
View File

@ -0,0 +1,309 @@
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) ) )))

4
development/chicken/slack-desc
View File

@ -6,9 +6,9 @@
# customary to leave one space after the ':' except on otherwise blank lines.
|-----handy-ruler------------------------------------------------------|
chicken: chicken (a practical and portable scheme system)
chicken: Chicken (a practical and portable scheme system)
chicken:
chicken: chicken is a compiler that translates Scheme source files into C,
chicken: Chicken is a compiler that translates Scheme source files into C,
chicken: which in turn can be fed to a C compiler to generate a standalone
chicken: executable. An interpreter is also available and can be used as a
chicken: scripting environment or for test programs before compilation.