1 files changed, 116 insertions, 0 deletions
diff --git a/modules/language/python/yield.scm b/modules/language/python/yield.scm
new file mode 100644
index 0000000..289eb4d
--- /dev/null
+++ b/modules/language/python/yield.scm
@@ -0,0 +1,116 @@
+(define-module (language python yield)
+  #:use-module (oop pf-objects)
+  #:use-module (language python exceptions)
+  #:use-module (oop goops)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:replace (send)
+  #:export (<yield> in-yield yield define-generator
+                    make-generator
+                    sendException sendClose))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
+(define in-yield (make-fluid #f))
+
+(define-syntax-parameter YIELD (lambda (x) #f))
+
+(define-syntax yield
+  (lambda (x)
+    (syntax-case x ()
+      ((_ x ...)
+       #'(begin
+           (fluid-set! in-yield #t)
+           abort-to-prompt YIELD x ...))
+      (x
+       #'(lambda x
+           (fluid-set! in-yield #t)
+           (apply abort-to-prompt YIELD x))))))
+
+(define-syntax-rule (make-generator (args) code ...)
+  (lambda args
+    (let ()
+      (define obj   (make <yield>))
+      (define ab (make-prompt-tag))
+      (syntax-parameterize ((YIELD (lambda x #'ab)))
+        (slot-set! obj 'k #f)
+        (slot-set! obj 'closed #f)
+        (slot-set! obj 's
+                   (lambda ()
+                     (call-with-prompt
+                      ab
+                      (lambda ()
+                        code ...
+                        (slot-set! obj 'closed #t)
+                        (throw StopIteration))
+                      (letrec ((lam
+                                (lambda (k . l)
+                                  (set! in-yield #f)
+                                  (slot-set! obj 'k
+                                             (lambda (a)
+                                               (call-with-prompt
+                                                ab
+                                                (lambda ()
+                                                  (k a))
+                                                lam)))
+                                  (apply values l))))
+                        lam))))
+        ob))))
+
+(define-syntax-rule (define-generator (f . args) code ...)
+  (define f (make-generator args code ...)))
+(define-class <yield>      () s k closed)
+
+(define-method (send (l <yield>) . u)
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if (not c)
+        (if k
+            (k (lambda ()
+                 (if (null? u)
+                     'Null
+                     (apply values u))))
+            (throw 'python (Exception))))))
+
+
+(define-method (sendException (l <yield>) e . ls)
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if (not c)
+        (if k
+            (k (lambda () (throw 'python (apply e ls))))
+            (throw 'python (Exception))))))
+
+(define-method (sendClose (l <yield>))
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's))
+        (c (slot-ref l 'closed)))
+    (if c
+        (values)
+        (if k
+            (catch #t
+              (lambda ()
+                (k (lambda () (throw 'python GeneratorExit)))
+                (slot-set! l 'closed #t)
+                (throw 'python RuntimeError))
+              (lambda (k tag . v)
+                (slot-set! l 'closed #t)
+                (if (eq? tag 'python)
+                    (match v
+                      ((tag . l)
+                       (if (eq? tag GeneratorExit)
+                           (values)
+                           (apply throw tag l))))
+                    (apply throw tag v))))
+            (slot-set! l 'closed #t)))))
+
+(define-method (send (l <p>) . u)
+  (apply (ref l '__send__) u))
+
+(define-method (sendException (l <p>) . u)
+  (apply (ref l '__exception__) u))
+
+(define-method (sendClose (l <p>))
+  ((ref l '__close__)))