#lang scheme/base
(require mzlib/trace
scheme/contract
scheme/match
(for-syntax scheme/base)
scheme/stxparam
)
(define non-match (make-thread-cell '()))
(define (ref)
(thread-cell-ref non-match))
(define (push! v)
(let ((lst (cons v (ref))))
(thread-cell-set! non-match lst)))
(define (rewind!)
(let ((v (thread-cell-ref non-match)))
(thread-cell-set! non-match '())
(thread-rewind-receive v)))
(define-syntax-parameter it
(lambda (stx) (raise-syntax-error #f "illegal use" stx)))
(define-syntax receive/match
(syntax-rules (after else sync)
((~ (pat exp exp2 ...) ... (else e1 e2 ...) (after time a1 a2 ...))
(raise-syntax-error 'receive/match "else keyword is not supported"))
((~ (pat exp exp2 ...) ... (else eexp eexp2 ...))
(raise-syntax-error 'receive/match "else keyword is not supported"))
((~ lst (sync (pat1 e1 e2 ...) ...))
(let ((evt (apply sync lst)))
(match evt (pat1 e1 e2 ...) ...)))
((~ lst (pat exp exp2 ...) ... (after time a1 a2 ...) (sync (pat1 e1 e2 ...) ...))
(let loop ((alarm (alarm-evt (+ (current-inexact-milliseconds) (* 1000 time))))
(thd-evt (thread-receive-evt)))
(let ((evt (apply sync alarm thd-evt lst)))
(cond ((eq? evt thd-evt)
(let ((v (thread-receive)))
(match v (pat (rewind!) exp exp2 ...)
...
(else (push! v)
(loop alarm thd-evt)))))
((eq? evt alarm) a1 a2 ...)
(else
(match evt (pat1 e1 e2 ...) ...))))))
((~ (pat exp exp2 ...) ... (after time aexp aexp2 ...))
(let loop ((alarm (alarm-evt (+ (current-inexact-milliseconds) (* 1000 time))))
(thd-evt (thread-receive-evt)))
(cond ((eq? (sync alarm thd-evt) thd-evt)
(let ((v (thread-receive)))
(match v (pat (rewind!) exp exp2 ...)
...
(else (push! v)
(loop alarm thd-evt)))))
(else aexp aexp2 ...))))
((~ lst (pat exp exp2 ...) ... (sync (pat1 e1 e2 ...) ...))
(let loop ((thd-evt (thread-receive-evt)))
(let ((evt (apply sync thd-evt lst)))
(cond ((eq? evt thd-evt)
(let ((v (thread-receive)))
(match v (pat (rewind!) exp exp2 ...)
...
(else (push! v)
(loop thd-evt)))))
(else
(match evt (pat1 e1 e2 ...) ...))))))
((~ (pat exp exp2 ...) ...)
(let loop ((v (thread-receive)))
(match v
(pat (rewind!) exp exp2 ...)
...
(else (push! v)
(loop (thread-receive))))))
((~ (after time exp exp2 ...))
(begin
(sync/timeout time)
exp exp2 ...))
))
(define (self? thd)
(eq? (current-thread) thd))
(define (==? x)
(lambda (y)
(eq? x y)))
(define (send-exn-to exn thd (on-behalf (current-thread)))
(thread-send thd (cons exn on-behalf) #f))
(define (make-send-exn-to thd)
(lambda (e)
(send-exn-to e thd)))
(define (thread/link proc (thd (current-thread)))
(thread (lambda ()
(with-handlers ((exn?
(make-send-exn-to thd)))
(proc)))))
(define (thread-cast* thd . args)
(thread-resume thd (current-thread))
(thread-send thd args))
(define (thread-cast thd arg)
(thread-resume thd (current-thread))
(thread-send thd (list arg)))
(define (thread-call thd arg (timeout +inf.0))
(thread-resume thd (current-thread))
(thread-send thd (list (current-thread) arg))
(let ((sender? (==? thd)))
(receive/match
((list (? sender? thd) v) v)
((cons (? exn? e) (? sender? thd))
(raise e))
(after timeout
(error 'thread-call "time-out")))))
(define (thread-reply thd v (on-behalf (current-thread)))
(thread-send thd (list on-behalf v) #f))
(provide/contract
(send-exn-to (->* (exn? thread?) (thread?) any))
(make-send-exn-to (-> thread? (-> exn? any)))
(thread/link (->* (procedure?) (thread?) thread?))
(self? (-> any/c any))
(==? (-> any/c any))
(thread-call (->* (thread? any/c)
(number?)
any))
(thread-cast (-> thread? any/c any))
(thread-cast* (->* (thread?)
()
#:rest (listof any/c)
any))
(thread-reply (->* (thread? any/c)
(thread?)
any))
)
(provide receive/match
)