1  #lang racket/base
  2  (require racket/contract
  3           (for-syntax racket/base))
  4  
  5  (provide coroutine)
  6  (provide
  7   (contract-out
  8    [coroutine-run (-> coroutine? any/c boolean?)]
  9    [coroutine-runnable? (-> coroutine? boolean?)]
 10    [coroutine-value (-> coroutine? any/c)]))
 11  
 12  (define-syntax (coroutine stx)
 13    (define-values (timeout more-stx)
 14      (syntax-case stx ()
 15        [(_ #:at-least msec-expr . more)
 16         (values #'msec-expr #'more)]
 17        [(_ . more) (values #'#f #'more)]))
 18    (syntax-case more-stx ()
 19      [(pause-id first-id exp1 exp2 ...)
 20       #`(coroutine/proc #,timeout (λ (pause-id first-id) exp1 exp2 ...))]))
 21  
 22  (struct coroutine ([run-proc #:mutable]
 23                     [val #:mutable]
 24                     tag
 25                     [last-start #:mutable]
 26                     expiry)
 27    #:omit-define-syntaxes
 28    #:extra-constructor-name
 29    make-coroutine)
 30  
 31  (define (coroutine/proc expiry cproc)
 32    (define tag (make-continuation-prompt-tag 'coroutine))
 33    (define (pauser)
 34      (define actually-pause?
 35        (cond
 36          [(coroutine-last-start the-coroutine)
 37           =>
 38           (λ (start-time)
 39             (define now (get-time))
 40             ((- now start-time) . >= . (coroutine-expiry the-coroutine)))]
 41          [else #t]))
 42      (when actually-pause?
 43        (call-with-composable-continuation 
 44         (λ (k) (abort-current-continuation tag k))
 45         tag)))
 46    (define the-coroutine
 47      (make-coroutine (λ (first-val) (values (cproc pauser first-val) #t))
 48                      #f
 49                      tag
 50                      #f
 51                      expiry))
 52    the-coroutine)
 53  
 54  (define (get-time) (current-process-milliseconds (current-thread)))
 55  
 56  (define (coroutine-run a-coroutine val)
 57    (cond
 58      [(coroutine-run-proc a-coroutine)
 59       =>
 60       (λ (proc)
 61         (when (coroutine-expiry a-coroutine)
 62           (set-coroutine-last-start! a-coroutine (get-time)))
 63         (define-values (res done?)
 64           (call-with-continuation-prompt
 65            (λ () (proc val))
 66            (coroutine-tag a-coroutine)
 67            (λ (k)
 68              (set-coroutine-run-proc! 
 69               a-coroutine
 70               (λ (next-val)
 71                 (k next-val)))
 72              (values #f #f))))
 73         (cond
 74           [done?
 75            (set-coroutine-run-proc! a-coroutine #f)
 76            (set-coroutine-val! a-coroutine res)
 77            #t]
 78           [else #f]))]
 79      [else
 80       (error 'coroutine-run "coroutine already terminated")]))
 81  
 82  (define (coroutine-runnable? a-coroutine)
 83    (and (coroutine-run-proc a-coroutine) 
 84         #t))
 85  
 86  (define (coroutine-value a-coroutine)
 87    (when (coroutine-runnable? a-coroutine)
 88      (error 'coroutine-value "coroutine not yet finished"))
 89    (coroutine-val a-coroutine))
 90  
 91  (module+ test
 92    (require rackunit)
 93    
 94    (define c
 95      (coroutine
 96       pause
 97       first
 98       (begin
 99         (printf "first ~s\n" first)
100         (let loop ([i 5])
101           (printf "i ~a\n" i)
102           (when (zero? (modulo i 3))
103             (printf ">> ~a\n" (pause)))
104           (cond
105             [(zero? i) '()]
106             [else
107              (cons i (loop (- i 1)))])))))
108    
109    (define (with-stdout th)
110      (define sp (open-output-string))
111      (list (parameterize ([current-output-port sp])
112              (th))
113            (get-output-string sp)))
114    
115    (check-equal? (with-stdout (λ () (coroutine-run c 123)))
116                  (list #f "first 123\ni 5\ni 4\ni 3\n"))
117    
118    (check-equal? (with-stdout (λ () (coroutine-run c 456)))
119                  (list #f ">> 456\ni 2\ni 1\ni 0\n"))
120    
121    (check-equal? (with-stdout (λ () (coroutine-run c 789)))
122                  (list #t ">> 789\n"))
123    
124    (check-equal? (coroutine-value c)
125                  '(5 4 3 2 1))
126    
127    
128    (define c2
129      (coroutine
130       pause first
131       (define x first)
132       (define (try-it)
133         (define new-x (pause))
134         (printf "~a => ~a\n" x new-x)
135         (set! x new-x))
136       (try-it)
137       (try-it)
138       x))
139    
140    (check-equal? (with-stdout (λ () (coroutine-run c2 0)))
141                  (list #f ""))
142    (check-equal? (with-stdout (λ () (coroutine-run c2 1)))
143                  (list #f "0 => 1\n"))
144    (check-equal? (with-stdout (λ () (coroutine-run c2 2)))
145                  (list #t "1 => 2\n"))
146    (check-equal? (coroutine-value c2)
147                  2)
148  
149    (check-equal?
150     (let ([c (coroutine
151               #:at-least 100
152               pause first
153               (pause)
154               (printf "hi"))])
155       (with-stdout (λ () (coroutine-run c 'whatever))))
156     (list #t "hi"))
157  
158    (check-equal?
159     (let ([c (coroutine
160               #:at-least 0
161               pause first
162               (pause)
163               (printf "hi"))])
164       (with-stdout (λ () (coroutine-run c 'whatever))))
165     (list #f "")))