581cbb461b
place will have initial input names, so having this first will make existing code break with an easy to fix syntax error, rather than having confusing failures. (Also made it throw a very clear error message if there is no () now.) svn: r18705
133 lines
4.5 KiB
Scheme
133 lines
4.5 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base)
|
|
scheme/control
|
|
scheme/stxparam scheme/splicing)
|
|
|
|
(provide yield generator generator-state in-generator infinite-generator
|
|
sequence->generator sequence->repeated-generator)
|
|
|
|
;; (define-syntax-parameter yield
|
|
;; (lambda (stx)
|
|
;; (raise-syntax-error
|
|
;; #f "yield is only bound inside a sequence generator")))
|
|
|
|
;; (define (procedure->generator proc)
|
|
;; (define tag (make-continuation-prompt-tag))
|
|
;; (define (cont)
|
|
;; (reset-at tag
|
|
;; (let ([r (proc (lambda (r) (shift-at tag k (set! cont k) r)))])
|
|
;; ;; normal return:
|
|
;; (set! cont (lambda () r))
|
|
;; r)))
|
|
;; (lambda () (cont)))
|
|
|
|
;; not using parameterization (old version, doesn't deal with multiple
|
|
;; inputs/outputs as the one below)
|
|
#;
|
|
(define-syntax-rule (generator body0 body ...)
|
|
(let ([tag (make-continuation-prompt-tag)])
|
|
(define yielder
|
|
(let ([yield (lambda (value) (shift-at tag k (set! cont k) value))])
|
|
yield))
|
|
(splicing-syntax-parameterize ([yield (make-rename-transformer #'yielder)])
|
|
(define (cont)
|
|
(reset-at tag
|
|
(let ([retval (begin body0 body ...)])
|
|
;; normal return:
|
|
(set! cont (lambda () retval))
|
|
retval))))
|
|
(define (generator) (cont))
|
|
generator))
|
|
|
|
(define current-yielder
|
|
(make-parameter
|
|
(lambda (v)
|
|
(error 'yield "must be called in the context of a generator"))))
|
|
|
|
(define yield
|
|
(case-lambda [() ((current-yielder))]
|
|
[(v) ((current-yielder) v)]
|
|
[vs (apply (current-yielder) vs)]))
|
|
|
|
(define yield-tag (make-continuation-prompt-tag))
|
|
|
|
(define-syntax (generator stx)
|
|
(syntax-case stx ()
|
|
[(_ () body0 body ...) #'(generator-old body0 body ...)]
|
|
[_ (raise-syntax-error
|
|
'generator "must have a form of (generator () body ...)")]))
|
|
|
|
(define-syntax-rule (generator-old body0 body ...)
|
|
(let ([state 'fresh])
|
|
(define (cont)
|
|
(define (yielder . vs)
|
|
(set! state 'suspended)
|
|
(shift-at yield-tag k (set! cont k) (apply values vs)))
|
|
(set! state 'running)
|
|
(reset-at yield-tag
|
|
(parameterize ([current-yielder yielder])
|
|
(call-with-values
|
|
(lambda () (begin body0 body ...))
|
|
;; get here only on at the end of the generator
|
|
(lambda rs
|
|
(set! cont (lambda () (set! state 'done) (apply values rs)))
|
|
(cont))))))
|
|
(define (err [what "send a value to"])
|
|
(error 'generator "cannot ~a a ~a generator" what state))
|
|
(define generator
|
|
(case-lambda
|
|
[() (if (eq? state 'running)
|
|
(err "call")
|
|
(begin (set! state 'running) (cont)))]
|
|
;; yield-tag means return the state (see `generator-state' below)
|
|
[(x) (cond [(eq? x yield-tag) state]
|
|
[(memq state '(suspended running))
|
|
(set! state 'running)
|
|
(cont x)]
|
|
[else (err)])]
|
|
[xs (if (memq state '(suspended running))
|
|
(begin (set! state 'running) (apply cont xs))
|
|
(err))]))
|
|
generator))
|
|
|
|
;; Get the state -- this is a hack: uses yield-tag as a hidden value that makes
|
|
;; the generator return its state. Protect against grabbing this tag (eg, with
|
|
;; (generator-state values)) by inspecting the result (so it can still be
|
|
;; deceived, but that will be harmless).
|
|
(define (generator-state g)
|
|
(let ([s (and (procedure? g) (procedure-arity-includes? g 1) (g yield-tag))])
|
|
(if (memq s '(fresh running suspended done))
|
|
s
|
|
(raise-type-error 'generator-state "generator" g))))
|
|
|
|
(define-syntax-rule (infinite-generator body0 body ...)
|
|
(generator () (let loop () body0 body ... (loop))))
|
|
|
|
(define stop-value (gensym))
|
|
|
|
(define-sequence-syntax in-generator
|
|
(syntax-rules ()
|
|
[(_ body0 body ...)
|
|
(in-producer (generator () body0 body ... stop-value) stop-value)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[((id ...) (_ body0 body ...))
|
|
#'[(id ...)
|
|
(in-producer (generator () body0 body ... stop-value)
|
|
stop-value)]])))
|
|
|
|
(define (sequence->generator sequence)
|
|
(generator () (for ([i sequence]) (yield i))))
|
|
|
|
(define (sequence->repeated-generator sequence)
|
|
(sequence->generator (in-cycle sequence)))
|
|
|
|
#|
|
|
;; examples
|
|
(for/list ([i (in-generator (for-each yield '(1 2 3)) (yield 'four))]) i)
|
|
(for*/list ([i (in-generator (for-each yield '(1 2 3)) (yield 'four))]
|
|
[j (in-generator (yield 'X) (yield '-))])
|
|
(list i j))
|
|
|#
|