fix coroutine API and test to avoid timeout races

svn: r8900

collects/mzlib/scribblings/thread.scrbl

@@ -30,13 +30,14 @@ Returns @scheme[#t] if @scheme[v] is a coroutine produced by
 @scheme[coroutine], @scheme[#f] otherwise.}
 
 
-@defproc[(coroutine-run [timeout-secs real?][coroutine coroutine?]) 
+@defproc[(coroutine-run [until (or/c evt? real?)][coroutine coroutine?]) 
          boolean?]{
 
 Allows the thread associated with @scheme[coroutine] to execute for up
-to @scheme[timeout-secs]. If @scheme[coroutine]'s procedure disables
+as long as @scheme[until] milliseconds (of @scheme[until] is a real
-suspends, then the coroutine can run arbitrarily long until it
+number) or @scheme[until] is ready (if @scheme[until] is an event). If
-re-enables suspends.
+@scheme[coroutine]'s procedure disables suspends, then the coroutine
+can run arbitrarily long until it re-enables suspends.
 
 The @scheme[coroutine-run] procedure returns @scheme[#t] if
 @scheme[coroutine]'s procedure completes (or if it completed earlier),

collects/mzlib/thread.ss

@@ -163,7 +163,9 @@
           void
           ;; Let the co-routine run...
           (lambda ()
-            (sync (choice-evt (wrap-evt (alarm-evt (+ timeout (current-inexact-milliseconds)))
+            (sync (choice-evt (wrap-evt (if (evt? timeout)
+                                            timeout
+                                            (alarm-evt (+ timeout (current-inexact-milliseconds))))
                                         (lambda (x)
                                           #;(printf "2. alarm-evt~n")
                                           (semaphore-wait can-stop-lock)
@@ -208,6 +210,6 @@
   (provide coroutine?)
   (provide/contract
    (coroutine (((any/c . -> . any) . -> . any) . -> . coroutine?))
-   (coroutine-run (real? coroutine? . -> . boolean?))
+   (coroutine-run ((or/c evt? real?) coroutine? . -> . boolean?))
    (coroutine-result (coroutine? . -> . any))
    (coroutine-kill (coroutine? . -> . any))))

collects/tests/mzscheme/threadlib.ss

@@ -56,18 +56,19 @@
 
 ;; coroutines ----------------------------------------
 
-(define MAX-RUN-TIME 100) ; in msecs
-
 (define cntr 0)
+(define cntr-sema (make-semaphore))
 (define w (coroutine (lambda (enable-stop)
 		       (let loop ((i 0))
 			 (enable-stop #f)
 			 (set! cntr i)
+                         (when (= cntr 1)
+                           (semaphore-post cntr-sema))
 			 (enable-stop #t)
 			 (loop (add1 i))))))
 (test #t coroutine? w)
 (test #f coroutine-result w)
-(test #f coroutine-run MAX-RUN-TIME w)
+(test #f coroutine-run cntr-sema w)
 (test #t positive? cntr)
 (test (void) coroutine-kill w)
 (test #t coroutine-run 100 w)
@@ -81,13 +82,13 @@
 			    (set! cntr i)
 			    (enable-stop #t)
 			    (loop (sub1 i))))))))
-(test #t coroutine-run MAX-RUN-TIME w2)
+(test #t coroutine-run (system-idle-evt) w2)
 (test 13 coroutine-result w2)
 (test #t coroutine-run 100 w2)
 
 (define w3 (coroutine (lambda (enable-stop)
 			(raise 14))))
-(err/rt-test (coroutine-run MAX-RUN-TIME w3) (lambda (x) (eq? x 14)))
+(err/rt-test (coroutine-run (system-idle-evt) w3) (lambda (x) (eq? x 14)))
 (test #f coroutine-result w3)
 (test #t coroutine-run 100 w3)
 
@@ -95,7 +96,7 @@
 			(enable-stop #f)
 			(raise 15))))
 (test #f coroutine-result w4)
-(err/rt-test (coroutine-run MAX-RUN-TIME w4) (lambda (x) (eq? x 15)))
+(err/rt-test (coroutine-run (system-idle-evt) w4) (lambda (x) (eq? x 15)))
 (test #t coroutine-run 100 w4)
 
 (report-errs)

collects/tests/r6rs/base.ss

@@ -1005,7 +1005,7 @@
           'ok)
     
     (test p.car 4)
-    ; (test/exn (set! p.car 15) &syntax)
+    ; (test/exn (set! p.car 15) &syntax) - not a runtime test
 
     (test/unspec (set! p2.car 15))
     (test p2.car 15)

collects/tests/r6rs/test.ss

@@ -108,7 +108,7 @@
           (display " tests passed\n"))
         (begin
           (display (length failures))
-          (display " tests failed:\n")
+          (display " tests failed:\n\n")
           (for-each (lambda (t)
                       (display "Expression:\n ")
                       (write (car t))
@@ -116,7 +116,7 @@
                       (write (cadr t))
                       (display "\nExpected:\n ")
                       (write (caddr t))
-                      (newline))
+                      (display "\n\n"))
                     (reverse failures))
           (display (length failures))
           (display " of ")