Fixing flag reset bug

ext/socket/socket-selector.incl

@@ -273,7 +273,9 @@ SgObject Sg_SocketSelectorWait(SgSocketSelector *selector, SgObject timeout)
 
   Sg_LockMutex(&selector->lock);
   selector->waiting = FALSE;
+
   if (SG_NULLP(r) && selector->retry) {
+    selector->retry = FALSE;
     /*
       socket is added during waiting. here we do
       - update timeout
@@ -294,8 +296,6 @@ SgObject Sg_SocketSelectorWait(SgSocketSelector *selector, SgObject timeout)
     sp = update_timeout(selector->sockets, &start, sp, &sock_to, &timedout);
     strip_sockets(selector, timedout);
     n = selector_sockets(selector);
-
-    selector->retry = FALSE;
 
     if (n == 0 && !SG_NULLP(timedout)) {
       Sg_UnlockMutex(&selector->lock);
@@ -307,6 +307,8 @@ SgObject Sg_SocketSelectorWait(SgSocketSelector *selector, SgObject timeout)
     goto retry;
   } else {
     SgObject strip;
+    /* reset it, in case of r is not null :) */
+    selector->retry = FALSE;
     if (!SG_NULLP(timedout)) {
       SgObject h = SG_NIL, t = SG_NIL, cp;
       SG_FOR_EACH(cp, r) {

ext/socket/test.scm

@@ -419,14 +419,19 @@
   (define server (make-server-socket "0"))
   (define selector (make-socket-selector))
   (define timeouts (make-atomic-fixnum 0))
-  (define (echo-back s) (socket-send s (socket-recv s 255)))
+  (define ready-counts (make-atomic-fixnum 0))
+  (define client-counts (make-atomic-fixnum 0))
+  (define (echo-back s)
+    (atomic-fixnum-inc! ready-counts)
+    (socket-send s (socket-recv s 255)))
   (define end? #f)
   (define t (thread-start!
 	     (make-thread
 	      (lambda ()
 		(let loop ()
 		  (let ((s (socket-accept server)))
 		    (when (and s (not end?))
+		      (atomic-fixnum-inc! client-counts)
 		      (socket-selector-add! selector s timeout)
 		      (loop))))))))
   (define t2
@@ -448,20 +453,25 @@
   (define result (make-atomic-fixnum 0))
   (define result-to (make-atomic-fixnum 0))
   (define (do-test i)
+    (define s (make-client-socket "localhost" (server-service server)))
+    (socket-set-read-timeout! s 500) ;; 500ms
     (thread-start!
      (make-thread
       (lambda ()
-	(let ((s (make-client-socket "localhost" (server-service server)))
-	      (msg (string->utf8 (string-append "hello " (number->string i)))))
-	  (socket-set-read-timeout! s 500) ;; 500ms
+	(let ((msg (string->utf8 (string-append "hello " (number->string i)))))
 	  (thread-sleep! delay)
 	  (guard (e (else (atomic-fixnum-inc! timeouts) #t))
 	    (socket-send s msg)
 	    (when (bytevector=? (socket-recv s 255) msg)
 	      (atomic-fixnum-inc! result)))
 	  (socket-shutdown s SHUT_RDWR)
 	  (socket-close s))))))
-  (for-each thread-join! (map do-test (iota count)))
+  (let ((t* (map do-test (iota count))))
+    (let loop ()
+      (unless (= count (atomic-fixnum-load client-counts))
+	(thread-sleep! delay)
+	(loop)))
+    (for-each thread-join! t*))
 
   (set! end? #t)
   (let ((s (make-client-socket "localhost" (server-service server))))
@@ -482,14 +492,17 @@
   (test-equal (format "timeouts (count = ~a, timeout = ~a)" count timeout)
 	      0 (atomic-fixnum-load timeouts))
 
-  (values (atomic-fixnum-load result) (atomic-fixnum-load result-to)))
+  (values (atomic-fixnum-load ready-counts)
+	  (atomic-fixnum-load result) (atomic-fixnum-load result-to)))
 
-(let-values (((r rt) (selector-test 500)))
+(let-values (((c r rt) (selector-test 500)))
+  (test-equal "no timeout (socket ready)" 500 c)
   (test-equal "no timeout (received)" 500 r)
   (test-equal "no timeout (timedout)" 0 rt))
 
-(let-values (((r rt) (selector-test 500 (duration:of-nanos 1))))
+(let-values (((c r rt) (selector-test 500 (duration:of-nanos 1))))
   ;; for some reason, some sockets don't timeout.
+  (test-assert "with timeout (socket ready)" (= r c))
   (test-assert "with timeout (received)" (< r 500))
   (test-assert "with timeout (timedout)" (< 0 rt))
   (test-equal "with timeout (total)" 500 (+ r rt)))