1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2 ;;;; The above modeline is required for Genera. Do not change.
4 (in-package :bordeaux-threads-2
)
6 #-
(or allegro clisp cmu genera sbcl
)
7 (define-condition interrupt
()
8 ((tag :initarg
:tag
:reader interrupt-tag
)))
10 #-
(or allegro clisp cmu genera sbcl
)
11 (defmacro with-timeout
((timeout) &body body
)
12 "Execute `BODY' and signal a condition of type TIMEOUT if the execution of
13 BODY does not complete within `TIMEOUT' seconds. On implementations which do not
14 support WITH-TIMEOUT natively and don't support threads either it signals a
15 condition of type `NOT-IMPLEMENTED`."
16 (declare (ignorable timeout body
))
19 (with-gensyms (ok-tag interrupt-tag caller interrupt-thread c
)
20 `(let (,interrupt-thread
)
21 (unwind-protect-case ()
23 (let* ((,interrupt-tag
(gensym "INTERRUPT-TAG-"))
24 (,caller
(current-thread)))
25 (setf ,interrupt-thread
31 #'(lambda () (signal 'interrupt
:tag
,interrupt-tag
))))
32 :name
(format nil
"WITH-TIMEOUT thread serving: ~S."
33 (thread-name ,caller
))))
35 ((interrupt #'(lambda (,c
)
36 (when (eql ,interrupt-tag
(interrupt-tag ,c
))
37 (error 'timeout
:length
,timeout
)))))
38 (throw ',ok-tag
(progn ,@body
)))))
40 (when (and ,interrupt-thread
(thread-alive-p ,interrupt-thread
))
41 ;; There's a potential race condition between THREAD-ALIVE-P
42 ;; and DESTROY-THREAD but calling the latter when a thread already
43 ;; terminated should not be a grave matter.
44 (ignore-errors (destroy-thread ,interrupt-thread
))))))))
46 `(signal-not-implemented 'with-timeout
))