awaitable futures for ChezScheme

future.ss

#!chezscheme
(library (future)
  (export spawn sync let-futures)
  (import (chezscheme))

  (define-record-type future
    (fields (immutable lock)
            (mutable completion)
            (mutable result))
    (nongenerative #{future cs11drvh6j3mxv5gy5626s-1})
    (protocol
      (lambda (new)
        (lambda (thunk)
          (let* ([m (make-mutex)]
                 [f (new m #f #f)])
            (fork-thread
              (lambda ()
                (with-mutex m
                  (guard (e [else (future-status-set! f 'error e)])
                    (call-with-values thunk
                      (case-lambda
                        [(single) (future-status-set! f 'single single)]
                        [many (future-status-set! f 'many many)]))))))
            (do ()
                ((not (mutex-acquire m #f)) f)
                (mutex-release m)))))))

  (define (future-status-set! f completion result)
    (future-completion-set! f completion)
    (future-result-set! f result))

  (define-syntax spawn
    (syntax-rules ()
      [(_ e* ...)
       (make-future (lambda () e* ...))]))

  (define (sync f)
    (let ([r (with-mutex (future-lock f)
                    (future-result f))])
      (case (future-completion f)
        [(error) (raise r)]
        [(single) r]
        [(many) (apply values r)]
        [else (errorf 'sync "Future neither failed nor successful. This should not be possible")])))

  (define-syntax let-futures
    (lambda (x)
      (syntax-case x ()
        [(_ ([id f] ...) b* ...)
         (with-syntax ([(t ...) (generate-temporaries #'(f ...))])
           #'(spawn
               (let ([t f] ...)
                 (let ([id (sync t)] ...)
                   b* ...))))])))
)