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@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)))))))))