45 lines
1.7 KiB
Racket
45 lines
1.7 KiB
Racket
#lang racket/base
|
|
|
|
(provide (struct-out exn:fail:timeout)
|
|
call-with-timeout)
|
|
|
|
|
|
(define-struct (exn:fail:timeout exn:fail) (msecs))
|
|
|
|
|
|
(define-struct good-value (v))
|
|
(define-struct bad-value (exn))
|
|
|
|
;; call-with-timeout: (-> any) number -> any
|
|
;; Calls a thunk, with a given timeout.
|
|
(define (call-with-timeout thunk timeout)
|
|
(let ([ch (make-channel)]
|
|
[alarm-e
|
|
(alarm-evt (+ (current-inexact-milliseconds)
|
|
timeout))])
|
|
(let* ([cust (make-custodian)]
|
|
[th (parameterize ([current-custodian cust])
|
|
(thread (lambda ()
|
|
(channel-put ch
|
|
(with-handlers ([void
|
|
(lambda (e)
|
|
(make-bad-value e))])
|
|
(make-good-value (thunk)))))))])
|
|
(let ([result (sync ch
|
|
(handle-evt alarm-e
|
|
(lambda (false-value)
|
|
(begin0
|
|
(make-bad-value
|
|
(make-exn:fail:timeout
|
|
"timeout"
|
|
(current-continuation-marks)
|
|
timeout))
|
|
(custodian-shutdown-all cust)
|
|
(kill-thread th)))))])
|
|
(cond
|
|
[(good-value? result)
|
|
(good-value-v result)]
|
|
[(bad-value? result)
|
|
(raise (bad-value-exn result))])))))
|
|
|