apiv2/timeout-interrupt.lisp

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