guile modifications git diff and strating supporting yield

1 files changed, 145 insertions, 69 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index ce503d9..302e780 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -130,6 +130,12 @@
      (defs y (defs x vs)))
     (_ vs)))
 
+(define (gen-yield f)
+  (string->symbol
+   (string-concat
+    (symbol->string f)
+    ".yield")))
+
 (define (g vs e)
   (lambda (x) (e vs x)))
 
@@ -405,14 +411,23 @@
                  code))))
           (lambda () ,(exp vs fin)))))
 
-    ((#:def (#:identifier f . _)
+    ((#:yield args)
+     '(scm-yield ,@gen-args(args)))
+
+    ((#:yield (f args))
+     (let ((f (gen-yield (exp vs f))))
+       '(,f ,@gen-args(args)))
+    
+    
+    ((#:def f
             (#:types-args-list
              args
              #f #f)
             #f
             code)
      (let* ((c? (fluid-ref is-class?))
-            (f  (string->symbol f))
+            (f  (exp vs f))
+            (y? (is-yield f #f code))
             (r  (gensym "return"))
             (as (map (lambda (x) (match x
                                   ((((#:identifier x . _) . #f) #f)
@@ -425,22 +440,26 @@
             (ls (diff (diff ns vs) df)))
        (with-fluids ((is-class? #f))
          (if c?
-             `(define ,f (letrec ((,f
-                                   (case-lambda
-                                     ((,ex ,@as)
-                                      (,f ,@as))
-                                     ((,@as)
-                                      (,(C 'with-return) ,r
-                                       (let ,(map (lambda (x) (list x #f)) ls)
-                                         ,(with-fluids ((return r))
-                                            (exp ns code))))))))
-                           ,f))
-
-             `(define ,f (lambda (,@as)
-                           (,(C 'with-return) ,r
-                            (let ,(map (lambda (x) (list x #f)) ls)
-                              ,(with-fluids ((return r))
-                                 (exp ns code))))))))))
+             `(define ,f
+                (def-wrap ,y?
+                  (letrec ((,f
+                            (case-lambda
+                              ((,ex ,@as)
+                               (,f ,@as))
+                              ((,@as)
+                               (,(C 'with-return) ,r
+                                (let ,(map (lambda (x) (list x #f)) ls)
+                                  ,(with-fluids ((return r))
+                                     (exp ns code))))))))
+                    ,f)))
+
+             `(define ,f
+                (def-wrap ,y?
+                  (lambda (,@as)
+                    (,(C 'with-return) ,r
+                     (let ,(map (lambda (x) (list x #f)) ls)
+                       ,(with-fluids ((return r))
+                          (exp ns code)))))))))))
      
     ((#:global . _)
      '(values))
@@ -541,6 +560,23 @@
 (define-syntax-parameter continue
   (lambda (x) (error "continue must be bound")))
 
+(define (is-yield f p x)
+  (match x
+    ((#:def nm args _ code)
+     (is-yield f #t code))
+    ((#:yield (x _))
+     (eq? f (exp '() x))) 
+    ((#:yield _)
+     (not p))
+    ((a . l)
+     (or
+      (is-yield f p a)
+      (is-yield f p l)))
+    (_
+     #f)))
+
+
+
 (define-syntax-rule (with-sp ((x v) ...) code ...)
   (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
 
@@ -737,30 +773,32 @@
       ((_ (x ...) (in ...) code #f #f)
        (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
          #'(let ((inv (wrap-in in)) ...)
-             (let lp ()
-               (call-with-values (lambda () (values (next inv) ...))
-                 (lambda (x ...)
-                   (if (or (non? x) ...)
-                       (values)
-                       (begin
-                         code
-                         (lp)))))))))
+             (catch StopIteration
+               (lambda ()
+                 (let lp ()
+                   (call-with-values (lambda () (values (next inv) ...))
+                     (lambda (x ...)
+                       (with-sp ((break    (values))
+                                 (continue (values)))
+                          code
+                          (lp))))))
+               (lambda x (values))))))
 
       ((_ (x ...) (in ...) code #f #t)
        (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
           #'(let ((inv (wrap-in in)) ...)
               (let lp ()
                 (let/ec break-ret
-                  (call-with-values (lambda () (values (next inv) ...))
-                    (lambda (x ...)
-                      (if (or (non? x) ...)
-                          (values)
-                          (begin
-                            (let/ec continue-ret
-                              (with-sp ((break     (break-ret))
-                                        (continue  (continue-ret)))
-                                       code))
-                            (lp))))))))))
+                  (catch StopIteration
+                    (lambda ()
+                      (call-with-values (lambda () (values (next inv) ...))
+                        (lambda (x ...)
+                          (let/ec continue-ret
+                            (with-sp ((break     (break-ret))
+                                      (continue  (continue-ret)))
+                                     code))
+                          (lp))))
+                    (lambda x (values))))))))
 
       ((_  (x ...) in code else #f)
        #'(for-adv (x ...) in code else #f))
@@ -780,62 +818,70 @@
     
     (syntax-case x ()
       ((_ (x ...) (in ...) code else p)
-       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
+       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
        (with-syntax ((get      (gen #'(inv ...) #'(x ...)))
                      ((xx ...) (generate-temporaries #'(x ...))))
-         #'(let ((inv (wrap-in in)) ...)
-             (if p
+         (if (syntax->datume #'p)
+             #'(let ((inv (wrap-in in)) ...)               
                  (let/ec break-ret
-                   (call-with-values
+                   (let ((x #f) ...)
+                     (catch StopIteration
                        (lambda ()
-                         (let lp ((xx #f) ...)
+                         (let lp ()
                            (call-with-values (lambda () get)
-                             (lambda (x ...)
+                             (lambda (xx ...)
+                               (set! x xx) ...
                                (let/ec continue-ret
-                                 (if (or (non? x) ...)
-                                     (values xx ...)
-                                     (with-sp ((break     (break-ret))
-                                               (continue  (continue-ret)))
-                                              code)))
-                               (lp x ...))))))
-                   (lambda (x ...) else))
-
-                 (let/ec break-ret
-                   (call-with-values
+                                 (with-sp ((break     (break-ret))
+                                           (continue  (continue-ret)))
+                                   code))
+                               (lp)))))
+                       (lambda q else)))))
+             
+             #'(let ((inv (wrap-in in)) ...)
+                 (let ((x #f) ...)
+                   (let/ec break-ret
+                     (catch StopIteration
                        (lambda ()
-                         (let lp ((xx #f) ...)
+                         (let lp ()
                            (call-with-values (lambda () get)
-                             (lambda (x ...)
-                               (if (or (non? x) ...)
-                                   (values xx ...)
-                                   (begin
-                                     (with-sp ((break     (break-ret))
-                                               (continue  (values)))
-                                       code)
-                                     (lp x ...)))))))
-                     (lambda (x ...) else)))))))))))
+                             (lambda (xx ...)
+                               (set! x xx) ...
+                               (with-sp ((break     (break-ret))
+                                         (continue  (values)))
+                                        code)
+                               (lp)))))
+                       (lambda e else))))))))))))
     
 
-(define-class <scm-list>   () (x) l)
-(define-class <scm-string> () (x) s i)
-
+(define-class <scm-list>   () l)
+(define-class <scm-string> () s i)
+(define-class <yield>      () k)
+  
 (define-method (next (l <scm-list>))
   (let ((ll (slot-ref l 'l)))
     (if (pair? ll)
         (begin
           (slot-set! l 'l (cdr ll))
           (car ll))
-        #:nil)))
+        (throw StopIteration))))
 
 (define-method (next (l <scm-string>))
   (let ((s (slot-ref l 's))
         (i (slot-ref l 'i)))
     (if (= i (string-length s))
-        #:nil
+        (throw StopIteration)
         (begin
           (slot-set! l 'i (+ i 1))
           (string-ref s i)))))
 
+(define-method (next (l <yield>))
+  (let ((k (slot-ref l 'k))
+        (s (slot-ref l 's)))
+    (if k
+        (k)
+        (s))))
+
 (define (wrap-in x)
   (cond
    ((pair? x)
@@ -849,6 +895,36 @@
       (slot-set! o 'i 0)
       o))
    
-    (else
-     x)))
+   (else
+    x)))
 
+(define yield-prompt (list 'yield))
+(define-syntax def-wrap
+  (lambda (x)
+    (syntax-case x ()
+      ((_ #f f x)
+       #'x)
+      
+      ((_ #t f code)
+       #'(lambda x
+           (define obj   (make <yield>))
+           (slot-set! obj 'k #f)
+           (slot-set! obj 'start
+                (lambda ()
+                  (let/ec return                          
+                    (with-prompt
+                     yield-prompt
+                     (lambda () (apply code x))
+                     (letrec ((lam
+                               (lambda (k . l)
+                                 (slot-set! obj 'k
+                                            (lambda ()
+                                              (with-prompt
+                                               yield-prompt
+                                               k
+                                               lam))))))
+                       lam))
+                    (throw StopIteration)))
+                      
+
+