>From 5adbb4eb40d9466e0fed68293af7a220dbf53f97 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 20 Nov 2013 23:05:40 +0100
Subject: [PATCH] Fix nonblocking socket behaviour on Windows by actually
 marking it nonblocking

---
 NEWS    |    1 +
 tcp.scm |   23 ++++++++++++++---------
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/NEWS b/NEWS
index 2f1e06d..abedfbb 100644
--- a/NEWS
+++ b/NEWS
@@ -14,6 +14,7 @@
   - Support has been added for the space-safe R7RS macro "delay-force".
   - Export file-type from the posix unit (thanks to Alan Post).
   - unsetenv has been fixed on Windows
+  - Nonblocking behaviour on sockets has been fixed on Windows.
 
 - Platform support
   - CHICKEN can now be built on AIX (contributed by Erik Falor)
diff --git a/tcp.scm b/tcp.scm
index c3689ae..a50f0c1 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -43,7 +43,6 @@
 /* Beware: winsock2.h must come BEFORE windows.h */
 # define socklen_t       int
 static WSADATA wsa;
-# define fcntl(a, b, c)  0
 # ifndef EWOULDBLOCK
 #  define EWOULDBLOCK     0
 # endif
@@ -55,6 +54,11 @@ static WSADATA wsa;
 # endif
 # define typecorrect_getsockopt(socket, level, optname, optval, optlen)	\
     getsockopt(socket, level, optname, (char *)optval, optlen)
+
+static C_word make_socket_nonblocking (C_word sock) {
+  int fd = C_unfix(sock);
+  C_return(C_mk_bool(ioctlsocket(fd, FIONBIO, (void *)&fd) != SOCKET_ERROR)) ;
+}
 #else
 # include <fcntl.h>
 # include <sys/types.h>
@@ -67,6 +71,13 @@ static WSADATA wsa;
 # define closesocket     close
 # define INVALID_SOCKET  -1
 # define typecorrect_getsockopt getsockopt
+
+static C_word make_socket_nonblocking (C_word sock) {
+  int fd = C_unfix(sock);
+  int val = fcntl(fd, F_GETFL, 0);
+  if(val == -1) C_return(C_SCHEME_FALSE);
+  C_return(C_mk_bool(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1));
+}
 #endif
 
 #ifndef SD_RECEIVE
@@ -125,12 +136,6 @@ EOF
       int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))
     "C_return(send(s, (char *)msg+offset, len, flags));"))
 
-(define ##net#make-nonblocking
-  (foreign-lambda* bool ((int fd))
-    "int val = fcntl(fd, F_GETFL, 0);"
-    "if(val == -1) C_return(0);"
-    "C_return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )
-
 (define ##net#getsockname 
   (foreign-lambda* c-string ((int s))
     "struct sockaddr_in sa;"
@@ -308,7 +313,7 @@ EOF
 (define ##net#io-ports
   (let ((tbs tcp-buffer-size))
     (lambda (loc fd)
-      (unless (##net#make-nonblocking fd)
+      (unless (##core#inline "make_socket_nonblocking" fd)
 	(network-error/close loc "cannot create TCP ports" fd) )
       (let* ((buf (make-string +input-buffer-size+))
 	     (data (vector fd #f #f buf 0))
@@ -544,7 +549,7 @@ EOF
     (let ((s (##net#socket _af_inet _sock_stream 0)) )
       (when (eq? -1 s)
 	(network-error 'tcp-connect "cannot create socket" host port) )
-      (unless (##net#make-nonblocking s)
+      (unless (##core#inline "make_socket_nonblocking" s)
 	(network-error/close 'tcp-connect "fcntl() failed" s) )
       (let loop ()
 	(when (eq? -1 (##net#connect s addr _sockaddr_in_size))
-- 
1.7.10.4