yield now works

1 files changed, 69 insertions, 42 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index b94e867..e515ded 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -6,6 +6,8 @@
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+
 (define-syntax clear-warning-data
   (lambda (x)
     (pr 'clear)
@@ -132,7 +134,7 @@
 
 (define (gen-yield f)
   (string->symbol
-   (string-concat
+   (string-append
     (symbol->string f)
     ".yield")))
 
@@ -158,10 +160,12 @@
                ',(exp vs las) ,u)))))))
 
 (define is-class? (make-fluid #f))
+(define (gen-yargs vs x)
+  (match (pr 'yarg x)    ((#:list args)
+     (map (g vs exp) args))))
 
 (define (exp vs x)
   (match (pr x)
-    
     ((#:power (x) () . #f)
      (exp vs x))
     ((#:power x () . #f)
@@ -180,6 +184,7 @@
           (match (pr x)
             ((#:identifier . _)
              (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer))
+
             ((#:arglist args #f #f)
              (lp `(,e ,@(map (g vs exp) args)) trailer))
             (_ (error "unhandled trailer")))))))
@@ -412,12 +417,12 @@
           (lambda () ,(exp vs fin)))))
 
     ((#:yield args)
-     '(scm-yield ,@gen-args(args)))
+     `(scm-yield ,@(gen-yargs vs args)))
 
-    ((#:yield (f args))
-     (let ((f (gen-yield (exp vs f))))
-       '(,f ,@gen-args(args)))
     
+    ((#:yield f args)
+     (let ((f (gen-yield (exp vs f))))
+       `(,f ,@(gen-yargs vs args))))
     
     ((#:def f
             (#:types-args-list
@@ -425,41 +430,55 @@
              #f #f)
             #f
             code)
-     (let* ((c? (fluid-ref is-class?))
-            (f  (exp vs f))
-            (y? (is-yield f #f code))
-            (r  (gensym "return"))
-            (as (map (lambda (x) (match x
-                                  ((((#:identifier x . _) . #f) #f)
-                                   (string->symbol x))))
-                     args))
-            (vs (union as vs))
-            (ns (scope code vs))
-            (df (defs code '()))
-            (ex (gensym "ex"))
-            (ls (diff (diff ns vs) df)))
+     (let* ((c?  (fluid-ref is-class?))
+            (f   (exp vs f))
+            (y?  (is-yield f #f code))
+            (r   (gensym "return"))
+            (as  (map (lambda (x) (match x
+                                    ((((#:identifier x . _) . #f) #f)
+                                     (string->symbol x))))
+                      args))
+            (ab  (gensym "ab"))
+            (vs  (union as vs))
+            (ns  (scope code vs))
+            (df  (defs code '()))
+            (ex  (gensym "ex"))
+            (y   'scm.yield)
+            (y.f (gen-yield f))
+            (ls  (diff (diff ns vs) df)))
+       
+       (define (mk code)
+         `(let-syntax ((,y   (syntax-rules ()
+                               ((_ . args)
+                                (abort-to-prompt ,ab . args))))
+                       (,y.f (syntax-rules ()
+                               ((_ . args)
+                                (abort-to-prompt ,ab . args)))))
+            ,code))
+       
        (with-fluids ((is-class? #f))
          (if c?
              `(define ,f
-                (def-wrap ,y?
+                (,(C 'def-wrap) ,y? ,f ,ab
                   (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))))))))
+                                  ,(mk `(let ,(map (lambda (x) (list x #f)) ls)
+                                         ,(with-fluids ((return r))
+                                            (exp ns code)))))))))
                     ,f)))
 
              `(define ,f
-                (def-wrap ,y?
+                (,(C 'def-wrap) ,y? ,f ,ab
                   (lambda (,@as)
                     (,(C 'with-return) ,r
                      (let ,(map (lambda (x) (list x #f)) ls)
                        ,(with-fluids ((return r))
-                          (exp ns code)))))))))))
+                          (mk
+                           (exp ns code))))))))))))
      
     ((#:global . _)
      '(values))
@@ -564,7 +583,7 @@
   (match x
     ((#:def nm args _ code)
      (is-yield f #t code))
-    ((#:yield (x _))
+    ((#:yield x _)
      (eq? f (exp '() x))) 
     ((#:yield _)
      (not p))
@@ -782,7 +801,7 @@
                                  (continue (values)))
                           code
                           (lp))))))
-               (lambda x (values))))))
+               (lambda z (values))))))
 
       ((_ (x ...) (in ...) code #f #t)
        (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
@@ -798,7 +817,7 @@
                                       (continue  (continue-ret)))
                                      code))
                           (lp))))
-                    (lambda x (values))))))))
+                    (lambda z (values))))))))
 
       ((_  (x ...) in code else #f)
        #'(for-adv (x ...) in code else #f))
@@ -821,7 +840,7 @@
        (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
        (with-syntax ((get      (gen #'(inv ...) #'(x ...)))
                      ((xx ...) (generate-temporaries #'(x ...))))
-         (if (syntax->datume #'p)
+         (if (syntax->datum #'p)
              #'(let ((inv (wrap-in in)) ...)               
                  (let/ec break-ret
                    (let ((x #f) ...)
@@ -856,7 +875,7 @@
 
 (define-class <scm-list>   () l)
 (define-class <scm-string> () s i)
-(define-class <yield>      () k)
+(define-class <yield>      () s k)
   
 (define-method (next (l <scm-list>))
   (let ((ll (slot-ref l 'l)))
@@ -907,29 +926,37 @@
 (define-syntax def-wrap
   (lambda (x)
     (syntax-case x ()
-      ((_ #f f x)
+      ((_ #f f ab x)
+       (pr 'def-wrap #'f 'false)
        #'x)
       
-      ((_ #t f code)
+      ((_ #t f ab code)
+       (pr 'def-wrap #'f 'true)
        #'(lambda x
            (define obj   (make <yield>))
+           (define ab (make-prompt-tag))
            (slot-set! obj 'k #f)
-           (slot-set! obj 'start
+           (slot-set! obj 's
                 (lambda ()
                   (let/ec return                          
-                    (with-prompt
-                     yield-prompt
-                     (lambda () (apply code x))
+                    (call-with-prompt
+                     ab
+                     (lambda ()
+                       (apply code x)
+                       (throw StopIteration))
                      (letrec ((lam
                                (lambda (k . l)
                                  (slot-set! obj 'k
                                             (lambda ()
-                                              (with-prompt
-                                               yield-prompt
-                                               k
-                                               lam))))))
-                       lam))
-                    (throw StopIteration)))
+                                              (call-with-prompt
+                                               ab
+                                               (lambda ()
+                                                 (k)
+                                                 (throw StopIteration))
+                                               lam)))
+                                 (apply values l))))
+                       lam)))))
+           obj)))))