Better WITH-TIMEOUT, add dependency on Alexandria.

bordeaux-threads.asd

@@ -44,6 +44,7 @@ Distributed under the MIT license (see LICENSE file)
   ;; - added Scieneer Common Lisp support
   :licence "MIT"
   :version "0.5.1"
+  :depends-on (:alexandria)
   :components ((:module "src"
                         :serial t
                         :components

src/allegro.lisp

@@ -68,8 +68,9 @@ Distributed under the MIT license (see LICENSE file)
 ;;; Timeouts
 
 (defmacro with-timeout ((timeout) &body body)
-  `(mp:with-timeout (,timeout)
-     ,@body))
+  (once-only (timeout)
+    `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
+       ,@body)))
 
 ;;; Introspection/debugging
 

src/bordeaux-threads.lisp

@@ -8,8 +8,7 @@ Distributed under the MIT license (see LICENSE file)
 
 (defpackage bordeaux-threads
   (:nicknames #:bt)
-  (:use #:cl)
-  #+sbcl (:import-from #:sb-ext #:timeout)
+  (:use #:cl #:alexandria)
   (:export #:make-thread #:current-thread #:threadp #:thread-name
            #:*default-special-bindings* #:*standard-io-bindings*
            #:*supports-threads-p*
@@ -92,8 +91,16 @@ Distributed under the MIT license (see LICENSE file)
                   "There is no support for this method on this implementation."
                   "There is no thread support in this instance."))))
 
-#-sbcl
-(define-condition timeout (serious-condition) ())
+(define-condition timeout (serious-condition)
+  ((length :initform nil
+             :initarg :length
+             :reader timeout-length))
+  (:report (lambda (c s)
+             (if (timeout-length c)
+                 (format s "A timeout set to ~A seconds occurred."
+                         (timeout-length c))
+                 (format s "A timeout occurred.")))))
+
 
 ;;; Thread Creation
 

src/clisp.lisp

@@ -80,11 +80,10 @@ Distributed under the MIT license (see LICENSE file)
 
 ;;; Timeouts
 
-;; VTZ: is there timeout-function (executed on timeout)?
-;; How to distinguish between NIL returned from body and timeout ?
 (defmacro with-timeout ((timeout) &body body)
-  `(mt:with-timeout (,timeout nil)
-     ,@body))
+  (once-only (timeout)
+    `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
+       ,@body)))
 
 ;;; Introspection/debugging
 

src/cmu.lisp

@@ -83,8 +83,9 @@ Distributed under the MIT license (see LICENSE file)
 ;;; Timeouts
 
 (defmacro with-timeout ((timeout) &body body)
-  `(mp:with-timeout (,timeout)
-     ,@body))
+  (once-only (timeout)
+    `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
+       ,@body)))
 
 ;;; Introspection/debugging
 

src/default-implementations.lisp

@@ -265,7 +265,7 @@ support WITH-TIMEOUT natively and don't support threads either it has no effect.
                                     :name (format nil "WITH-TIMEOUT thread serving: ~S."
                                                   (thread-name ,caller))))
                  (throw ',ok-tag (progn ,@body))))
-             (error 'timeout))
+             (error 'timeout :length timeout))
          (when (thread-alive-p ,sleeper)
            (destroy-thread ,sleeper)))))
   #-thread-support

src/sbcl.lisp

@@ -67,6 +67,8 @@ Distributed under the MIT license (see LICENSE file)
 
 ;;; Timeouts
 
+(deftype timeout () 'sb-ext:timeout)
+
 (defmacro with-timeout ((timeout) &body body)
   `(sb-ext:with-timeout ,timeout
      ,@body))

src/scl.lisp

@@ -61,11 +61,6 @@ Distributed under the MIT license (see LICENSE file)
 (defun thread-yield ()
   (mp:process-yield))
 
-;;; Timeouts
-
-(defmacro with-timeout ((timeout) &body body)
-  `(error "with-timeout is not reliable and should not be used."))
-
 ;;; Introspection/debugging
 
 (defun all-threads ()