Bidirectional generator for MzScheme.
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Tue, 06 Apr 2010 08:11:57 +1200
changeset 283 94f780251884
parent 282 36ad47fbeb8d
child 284 1bf8431909d4
Bidirectional generator for MzScheme.
experiments/bidi-generator-example.ss
experiments/bidi-generator.ss
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/bidi-generator-example.ss	Tue Apr 06 08:11:57 2010 +1200
@@ -0,0 +1,31 @@
+#lang scheme
+(require "bidi-generator.ss")
+
+(define (print-all)
+  (display "FIRST")
+  (newline)
+  (do ()
+    (#f)
+    (display (yield))
+    (newline)))
+
+(let ((pa (generator () (print-all))))
+  (pa)
+  (pa 1)
+  (pa 2)
+  (pa 3))
+
+(define (yield-four)
+  (generator ()
+             (yield 1)
+             (yield 2)
+             (yield 3)
+             (yield 4)
+             'final-value))
+
+(let ((x (yield-four)))
+  (display (x))
+  (display (x 'a))
+  (display (x 'b))
+  (display (x 'c))
+  (display (x 'd)))
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/bidi-generator.ss	Tue Apr 06 08:11:57 2010 +1200
@@ -0,0 +1,32 @@
+#lang scheme
+
+(provide yield generator)
+
+(define current-yielder
+  (make-parameter
+   (lambda (v)
+     (error 'yield "must be called in the context of a generator"))))
+
+(define (yield . vals)
+  (apply (current-yielder) vals))
+
+(define-syntax-rule (generator init-formals body0 body ...)
+  (letrec ((yielder (lambda vals
+                      (call-with-current-continuation
+                         (lambda (new-inner-k)
+                           (set! inner-k new-inner-k)
+                           (apply outer-k vals)))))
+           (outer-k #f)
+           (inner-k (lambda init-formals
+                      (call-with-values
+                       (lambda ()
+                         (parameterize ((current-yielder yielder))
+                           body0 body ...))
+                       (lambda results
+                         (set! inner-k (lambda ignored (error "Generator is terminated")))
+                         (apply outer-k results))))))
+    (lambda args
+      (call-with-current-continuation
+       (lambda (new-outer-k)
+         (set! outer-k new-outer-k)
+         (apply inner-k args))))))