Execute With Timeout

  ;;; (thanks to Martin Gasbichler)
  ;;; 
  ;;; This procedure executes a subprocedure in a separate thread in a
  ;;; given time period.  If the subprocedure hasn't completed
  ;;; by the time the number of seconds given as the second argument
  ;;; have elapsed it returns 'timeout.  For example
  ;;;
  ;;; (execute/timeout
  ;;;  (lambda () (run/strings (rsh phz-4 uptime)))
  ;;;  5)

  (define (execute/timeout proc sec)
    (let ((lock (make-lock))
          (done? #f)
          (result (make-placeholder)))
      (define (maybe-set-result! val)
        (obtain-lock lock)
        (cond ((not done?)
               (set! done? #t)
               (placeholder-set! result val)))
        (release-lock lock))
      (spawn (lambda ()
               (sleep (* sec 1000))
               (maybe-set-result! 'timeout)))
      (spawn (lambda ()
               (maybe-set-result! (proc))))
      (placeholder-value result)))
ExecuteWithTimeout - raw wiki source | code snippets archive