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