Hi Gary,
I've modified with-timeout.lisp to add LispWorks support. I've
"tested" it (where "tested" == "debugged"). I have attached a
unified diff and my modified source file.
It seemed to me that your uses of PROGN and VALUES were redundant,
and I'm curious as to why they were present (and/or whether I'm just
wrong).
I hope this is useful. I'd be interested in any comments or feedback
you might have.
Cheers,
John :^P
--
John Pallister
john(a)synchromesh.com
--- with-timeout-orig.lisp 2008-09-11 01:46:15.000000000 +1200
+++ with-timeout.lisp 2008-09-12 15:49:25.140625000 +1200
@@ -21,22 +21,23 @@
If `seconds` is nil, then the body will be run normally until it completes
or is interrupted."
(let ((gseconds (gensym "seconds-"))
+ (gdoit (gensym "doit-"))
#+(and sbcl (not sb-thread))
(glabel (gensym "label-"))
#+(and sbcl (not sb-thread))
(gused-timer? (gensym "used-timer-")))
`(let ((,gseconds ,seconds))
- (flet ((doit ()
- (progn ,@body)))
- (cond (,gseconds
+ (flet ((,gdoit ()
+ ,@body))
+ (cond ((and (numberp ,gseconds) (> ,gseconds 0))
#+allegro
(mp:with-timeout (,gseconds (error 'timeout-error))
- (doit))
+ (,gdoit))
#+cmu
- (mp:with-timeout (,gseconds) (doit))
+ (mp:with-timeout (,gseconds) (,gdoit))
#+(and sbcl sb-thread)
(handler-case
- (sb-ext:with-timeout ,gseconds (doit))
+ (sb-ext:with-timeout ,gseconds (,gdoit))
(sb-ext::timeout (c)
(error 'timeout-error)))
#+(and sbcl (not sb-thread))
@@ -47,7 +48,7 @@
(setf ,gused-timer? t)
(throw ',glabel nil)))
,gseconds)
- (doit))
+ (,gdoit))
(when ,gused-timer?
(error 'timeout-error)))
#+(or digitool openmcl ccl)
@@ -59,7 +60,7 @@
(,process (ccl:process-run-function
,checker-process
(lambda ()
- (setf ,result (progn (doit)))))))
+ (setf ,result (,gdoit))))))
(ccl:process-wait-with-timeout
,waiting-process
(* ,gseconds #+(or openmcl ccl)
@@ -69,8 +70,23 @@
(when (ccl::process-active-p ,process)
(ccl:process-kill ,process)
(cerror "Timeout" 'timeout-error))
- (values ,result)))
- #-(or allegro cmu sbcl openmcl ccl mcl digitool)
- (progn (doit)))
+ ,result))
+ #+lispworks
+ ,(let ((gresult (gensym "result-"))
+ (gprocess (gensym "process-")))
+ `(let* (,gresult
+ (,gprocess (mp:process-run-function "WITH-TIMEOUT"
+ '()
+ (lambda ()
+ (setq ,gresult (,gdoit))))))
+ (unless (mp:process-wait-with-timeout "WITH-TIMEOUT"
+ ,gseconds
+ (lambda ()
+ (not (mp:process-alive-p ,gprocess))))
+ (mp:process-kill ,gprocess)
+ (cerror "Timeout" 'timeout-error))
+ ,gresult))
+ #-(or allegro cmu sbcl openmcl ccl mcl digitool lispworks)
+ (,gdoit))
(t
- (doit)))))))))
+ (,gdoit)))))))))
(in-package #:com.metabang.trivial-timeout)
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (and (find-symbol (symbol-name '#:with-timeout)
'#:com.metabang.trivial-timeout)
(fboundp (find-symbol (symbol-name '#:with-timeout)
'#:com.metabang.trivial-timeout)))
(define-condition timeout-error (error)
()
(:report (lambda (c s)
(declare (ignore c))
(format s "Process timeout")))
(:documentation "An error signaled when the duration specified in
the [with-timeout][] is exceeded."))
(defmacro with-timeout ((seconds) &body body)
"Execute `body` for no more than `seconds` time.
If `seconds` is exceeded, then a [timeout-error][] will be signaled.
If `seconds` is nil, then the body will be run normally until it completes
or is interrupted."
(let ((gseconds (gensym "seconds-"))
(gdoit (gensym "doit-"))
#+(and sbcl (not sb-thread))
(glabel (gensym "label-"))
#+(and sbcl (not sb-thread))
(gused-timer? (gensym "used-timer-")))
`(let ((,gseconds ,seconds))
(flet ((,gdoit ()
,@body))
(cond ((and (numberp ,gseconds) (> ,gseconds 0))
#+allegro
(mp:with-timeout (,gseconds (error 'timeout-error))
(,gdoit))
#+cmu
(mp:with-timeout (,gseconds) (,gdoit))
#+(and sbcl sb-thread)
(handler-case
(sb-ext:with-timeout ,gseconds (,gdoit))
(sb-ext::timeout (c)
(error 'timeout-error)))
#+(and sbcl (not sb-thread))
(let ((,gused-timer? nil))
(catch ',glabel
(sb-ext:schedule-timer
(sb-ext:make-timer (lambda ()
(setf ,gused-timer? t)
(throw ',glabel nil)))
,gseconds)
(,gdoit))
(when ,gused-timer?
(error 'timeout-error)))
#+(or digitool openmcl ccl)
,(let ((checker-process (format nil "Checker ~S" (gensym)))
(waiting-process (format nil "Waiter ~S" (gensym)))
(result (gensym))
(process (gensym)))
`(let* ((,result nil)
(,process (ccl:process-run-function
,checker-process
(lambda ()
(setf ,result (,gdoit))))))
(ccl:process-wait-with-timeout
,waiting-process
(* ,gseconds #+(or openmcl ccl)
ccl:*ticks-per-second* #+digitool 60)
(lambda ()
(not (ccl::process-active-p ,process))))
(when (ccl::process-active-p ,process)
(ccl:process-kill ,process)
(cerror "Timeout" 'timeout-error))
,result))
#+lispworks
,(let ((gresult (gensym "result-"))
(gprocess (gensym "process-")))
`(let* (,gresult
(,gprocess (mp:process-run-function "WITH-TIMEOUT"
'()
(lambda ()
(setq ,gresult (,gdoit))))))
(unless (mp:process-wait-with-timeout "WITH-TIMEOUT"
,gseconds
(lambda ()
(not (mp:process-alive-p ,gprocess))))
(mp:process-kill ,gprocess)
(cerror "Timeout" 'timeout-error))
,gresult))
#-(or allegro cmu sbcl openmcl ccl mcl digitool lispworks)
(,gdoit))
(t
(,gdoit)))))))))
