diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm index 84041576..b5565f23 100644 --- a/lib/srfi/18/interface.scm +++ b/lib/srfi/18/interface.scm @@ -1,10 +1,22 @@ +(define current-time get-time-of-day) +(define time? timeval?) + +(define (time->seconds x) + (timeval-seconds (if (pair? x) (car x) x))) + +(define (seconds->time x) + (make-timeval (if (inexact? x) (inexact->exact (round x)) x) 0)) + +(define (timeout->seconds x) + (if (time? x) (- (time->seconds x) (time->seconds (current-time))) x)) + (define thread-yield! yield!) (define (thread-join! thread . o) (let ((timeout (if (pair? o) (car o) #f))) (cond - ((%thread-join! thread timeout)) + ((%thread-join! thread (timeout->seconds timeout))) (else (thread-yield!) (if (thread-timeout?) @@ -18,13 +30,13 @@ (thread-yield!))) (define (thread-sleep! timeout) - (%thread-sleep! timeout) + (%thread-sleep! (timeout->seconds timeout)) (thread-yield!)) (define (mutex-lock! mutex . o) (let ((timeout (and (pair? o) (car o))) (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) - (cond ((%mutex-lock! mutex timeout thread)) + (cond ((%mutex-lock! mutex (timeout->seconds timeout) thread)) (else (thread-yield!) (not (thread-timeout?)))))) @@ -32,20 +44,11 @@ (define (mutex-unlock! mutex . o) (let ((condvar (and (pair? o) (car o))) (timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f))) - (cond ((%mutex-unlock! mutex condvar timeout)) + (cond ((%mutex-unlock! mutex condvar (timeout->seconds timeout))) (else (thread-yield!) (not (thread-timeout?)))))) -(define current-time get-time-of-day) -(define time? timeval?) - -(define (time->seconds x) - (timeval-seconds (if (pair? x) (car x) x))) - -(define (seconds->time x) - (make-timeval (if (inexact? x) (inexact->exact x) x) 0)) - (define (join-timeout-exception? x) (and (exception? x) (equal? (exception-message x) "timed out waiting for thread")))