Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/timeout-interrupt.lisp

KindCoveredAll%
expression01 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2
 ;;;; The above modeline is required for Genera. Do not change.
3
 
4
 (in-package :bordeaux-threads-2)
5
 
6
 #-(or allegro clisp cmu genera sbcl)
7
 (define-condition interrupt ()
8
   ((tag :initarg :tag :reader interrupt-tag)))
9
 
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))
17
   #+thread-support
18
   (once-only (timeout)
19
     (with-gensyms (ok-tag interrupt-tag caller interrupt-thread c)
20
       `(let (,interrupt-thread)
21
          (unwind-protect-case ()
22
             (catch ',ok-tag
23
               (let* ((,interrupt-tag (gensym "INTERRUPT-TAG-"))
24
                      (,caller (current-thread)))
25
                 (setf ,interrupt-thread
26
                        (make-thread
27
                         #'(lambda ()
28
                             (sleep ,timeout)
29
                             (interrupt-thread
30
                              ,caller
31
                              #'(lambda () (signal 'interrupt :tag ,interrupt-tag))))
32
                         :name (format nil "WITH-TIMEOUT thread serving: ~S."
33
                                       (thread-name ,caller))))
34
                 (handler-bind
35
                     ((interrupt #'(lambda (,c)
36
                                     (when (eql ,interrupt-tag (interrupt-tag ,c))
37
                                       (error 'timeout :length ,timeout)))))
38
                   (throw ',ok-tag (progn ,@body)))))
39
            (:normal
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))))))))
45
   #-thread-support
46
   `(signal-not-implemented 'with-timeout))