srfi-18: When timeout is a number, it's a relative number of seconds.

Fixes <https://bugs.gnu.org/29704>.
Reported by David Beswick <dlbeswick@gmail.com>.

* module/srfi/srfi-18.scm (timeout->absolute-time): New procedure.
(mutex-lock!): Use it in 'thread:lock-mutex' call.
(mutex-unlock!): Use it.
* test-suite/tests/srfi-18.test ("mutex-lock! returns false on timeout")
("mutex-lock! returns true when lock obtained within timeout")
("recursive lock waits")
("mutex unlock is false when condition times out"): Adjust cases where
the 'timeout' parameter is a number so that it's a relative number.

2 files changed, 33 insertions, 24 deletions

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 4634623fe..6d6596ffb 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,6 +1,6 @@
 ;;; srfi-18.scm --- Multithreading support
 
-;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -139,6 +139,16 @@
 (define current-thread (make-parameter (%make-thread #f #f #f #f #f)))
 (define thread-mutexes (make-parameter #f))
 
+(define (timeout->absolute-time timeout)
+  "Return an absolute time in seconds corresponding to TIMEOUT.  TIMEOUT
+can be any value authorized by SRFI-18: a number (relative time), a time
+object (absolute point in time), or #f."
+  (cond ((number? timeout)                      ;seconds relative to now
+         (+ ((@ (guile) current-time)) timeout))
+        ((time? timeout)                         ;absolute point in time
+         (time->seconds timeout))
+        (else timeout)))                          ;pair or #f
+
 ;; EXCEPTIONS
 
 ;; All threads created by SRFI-18 have an initial handler installed that
@@ -308,7 +318,8 @@
   (with-exception-handlers-here
    (lambda ()
      (cond
-      ((threads:lock-mutex (mutex-prim mutex) timeout)
+      ((threads:lock-mutex (mutex-prim mutex)
+                           (timeout->absolute-time timeout))
        (set-mutex-owner! mutex thread)
        (when (mutex-abandoned? mutex)
          (set-mutex-abandoned?! mutex #f)
@@ -320,20 +331,21 @@
 (define %unlock-sentinel (list 'unlock))
 (define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
                         (timeout %unlock-sentinel))
-  (when (mutex-owner mutex)
-    (set-mutex-owner! mutex #f)
-    (cond
-     ((eq? cond-var %unlock-sentinel)
-      (threads:unlock-mutex (mutex-prim mutex)))
-     ((eq? timeout %unlock-sentinel)
-      (threads:wait-condition-variable (condition-variable-prim cond-var)
-                                       (mutex-prim mutex))
-      (threads:unlock-mutex (mutex-prim mutex)))
-     ((threads:wait-condition-variable (condition-variable-prim cond-var)
-                                       (mutex-prim mutex)
-                                       timeout)
-      (threads:unlock-mutex (mutex-prim mutex)))
-     (else #f))))
+  (let ((timeout (timeout->absolute-time timeout)))
+    (when (mutex-owner mutex)
+      (set-mutex-owner! mutex #f)
+      (cond
+       ((eq? cond-var %unlock-sentinel)
+        (threads:unlock-mutex (mutex-prim mutex)))
+       ((eq? timeout %unlock-sentinel)
+        (threads:wait-condition-variable (condition-variable-prim cond-var)
+                                         (mutex-prim mutex))
+        (threads:unlock-mutex (mutex-prim mutex)))
+       ((threads:wait-condition-variable (condition-variable-prim cond-var)
+                                         (mutex-prim mutex)
+                                         timeout)
+        (threads:unlock-mutex (mutex-prim mutex)))
+       (else #f)))))
 
 ;; CONDITION VARIABLES
 ;; These functions are all pass-thrus to the existing Guile implementations.
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index a6e184c6f..fc36dab8a 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -1,7 +1,7 @@
 ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
 ;;;; Julian Graham, 2007-10-26
 ;;;;
-;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2012, 2018 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -233,7 +233,7 @@
 
     (pass-if "mutex-lock! returns false on timeout"
       (let* ((m (make-mutex 'mutex-lock-2))
-             (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+             (t (make-thread (lambda () (mutex-lock! m 0 #f)))))
         (mutex-lock! m)
         (thread-start! t)
         (not (thread-join! t))))
@@ -241,9 +241,7 @@
     (pass-if "mutex-lock! returns true when lock obtained within timeout"
       (let* ((m (make-mutex 'mutex-lock-3))
              (t (make-thread (lambda () 
-                               (mutex-lock! m (+ (time->seconds (current-time)) 
-                                                 100)
-                                            #f)))))
+                               (mutex-lock! m 100 #f)))))
         (mutex-lock! m)
         (thread-start! t)
         (mutex-unlock! m)
@@ -306,8 +304,7 @@
       (let* ((m (make-mutex 'mutex-unlock-2))
              (t (make-thread (lambda ()
                                (mutex-lock! m)
-                               (let ((now (time->seconds (current-time))))
-                                 (mutex-lock! m (+ now 0.1)))
+                               (mutex-lock! m 0.1)
                                (mutex-unlock! m))
                              'mutex-unlock-2)))
         (thread-start! t)
@@ -352,7 +349,7 @@
       (let* ((m (make-mutex 'mutex-unlock-4))
              (c (make-condition-variable 'mutex-unlock-4)))
         (mutex-lock! m)
-        (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+        (not (mutex-unlock! m c 1)))))
 
   (with-test-prefix "condition-variable?"