~ chicken-core (chicken-5) e1e519311d08fc11a4e76e52ca4c599c6d7f4dad

commit e1e519311d08fc11a4e76e52ca4c599c6d7f4dad
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Apr 12 23:05:56 2013 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Apr 12 23:05:56 2013 +0200

    Old code that passes a fixnum timeout value to SRFI-18 functions that
    later invoke ##sys#thread-block-for-timeout! may cause the
    timeout-value (after massaging) to be 0. In this case nothing is
    done and thread will not block.

diff --git a/scheduler.scm b/scheduler.scm
index ee258fe4..4ef54e6a 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -292,19 +292,19 @@ EOF
 
 (define (##sys#thread-block-for-timeout! t tm)
   (dbg t " blocks for timeout " tm)
-  (unless (and (flonum? tm)			; to catch old code that uses fixum timeouts
-	       (fp> tm 0.0))
+  (unless (flonum? tm)	  ; to catch old code that uses fixnum timeouts
     (panic "##sys#thread-block-for-timeout!: invalid timeout"))
-  ;; This should really use a balanced tree:
-  (let loop ([tl ##sys#timeout-list] [prev #f])
-    (if (or (null? tl) (fp< tm (caar tl)))
-	(if prev
-	    (set-cdr! prev (cons (cons tm t) tl))
-	    (set! ##sys#timeout-list (cons (cons tm t) tl)) )
-	(loop (cdr tl) tl) ) ) 
-  (##sys#setslot t 3 'blocked)
-  (##sys#setislot t 13 #f)
-  (##sys#setslot t 4 tm) )
+  (when (fp> tm 0.0)
+    ;; This should really use a balanced tree:
+    (let loop ([tl ##sys#timeout-list] [prev #f])
+      (if (or (null? tl) (fp< tm (caar tl)))
+	  (if prev
+	      (set-cdr! prev (cons (cons tm t) tl))
+	      (set! ##sys#timeout-list (cons (cons tm t) tl)) )
+	  (loop (cdr tl) tl) ) ) 
+    (##sys#setslot t 3 'blocked)
+    (##sys#setislot t 13 #f)
+    (##sys#setslot t 4 tm) ) )
 
 (define (##sys#thread-block-for-termination! t t2)
   (dbg t " blocks for " t2)