49 lines
1.1 KiB
Racket
49 lines
1.1 KiB
Racket
#lang racket/base
|
|
;; Standard Thread
|
|
|
|
(provide exit-status?
|
|
exit-status-exception
|
|
|
|
current-thread-exit-status
|
|
exit-status-evt
|
|
|
|
standard-thread)
|
|
|
|
(struct exit-status (thread
|
|
[exception #:mutable]
|
|
ready))
|
|
|
|
(define *current-thread-exit-status* (make-parameter #f))
|
|
|
|
(define (current-thread-exit-status)
|
|
(define v (*current-thread-exit-status*))
|
|
(if (exit-status? v)
|
|
(if (eq? (current-thread) (exit-status-thread v))
|
|
v
|
|
(begin (*current-thread-exit-status* #f)
|
|
#f))
|
|
#f))
|
|
|
|
(define (exit-status-evt es)
|
|
(wrap-evt (semaphore-peek-evt (exit-status-ready es))
|
|
(lambda (dummy) es)))
|
|
|
|
(define (fill-exit-status! es exn)
|
|
(set-exit-status-exception! es exn)
|
|
(semaphore-post (exit-status-ready es)))
|
|
|
|
(define (call-capturing-exit-status thunk)
|
|
(define es (exit-status (current-thread) #f (make-semaphore 0)))
|
|
(parameterize ((*current-thread-exit-status* es))
|
|
(with-handlers
|
|
((exn? (lambda (e)
|
|
(fill-exit-status! es e)
|
|
(raise e))))
|
|
(define result (thunk))
|
|
(fill-exit-status! es #f)
|
|
result)))
|
|
|
|
(define (standard-thread thunk)
|
|
(thread (lambda ()
|
|
(call-capturing-exit-status thunk))))
|