yield now works
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 8 Sep 2017 22:26:06 +0000 (00:26 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 8 Sep 2017 22:26:06 +0000 (00:26 +0200)
modules/language/python/compile.scm
modules/oop/pf-objects.scm

index b94e867e3f5240fd6196c09f075899697230e439..e515ded925fa70efd6dc596625f0a6bb701842a7 100644 (file)
@@ -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)
 
 (define (gen-yield f)
   (string->symbol
-   (string-concat
+   (string-append
     (symbol->string f)
     ".yield")))
 
                ',(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)
           (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")))))))
           (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
              #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))
   (match x
     ((#:def nm args _ code)
      (is-yield f #t code))
-    ((#:yield (x _))
+    ((#:yield x _)
      (eq? f (exp '() x))) 
     ((#:yield _)
      (not p))
                                  (continue (values)))
                           code
                           (lp))))))
-               (lambda x (values))))))
+               (lambda z (values))))))
 
       ((_ (x ...) (in ...) code #f #t)
        (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
                                       (continue  (continue-ret)))
                                      code))
                           (lp))))
-                    (lambda x (values))))))))
+                    (lambda z (values))))))))
 
       ((_  (x ...) in code else #f)
        #'(for-adv (x ...) in code else #f))
        (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) ...)
 
 (define-class <scm-list>   () l)
 (define-class <scm-string> () s i)
-(define-class <yield>      () k)
+(define-class <yield>      () k)
   
 (define-method (next (l <scm-list>))
   (let ((ll (slot-ref l 'l)))
 (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)))))
                       
 
                       
index 44674fba7f40b8a708a4f2be149cfbd16a82eea5..91014158d3e0904936e4a0cbb6cc504f04ab8421 100644 (file)
@@ -1,7 +1,8 @@
 (define-module (oop pf-objects)
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
-  #:export (set ref make-pf <pf> call with copy fset fcall make-p put put!
+  #:export (set ref make-pf <p> <py> <pf> <pyf>
+                call with copy fset fcall make-p put put!
                 pcall pcall! get next
                 mk
                 def-pf-class  mk-pf-class  make-pf-class
@@ -554,7 +555,7 @@ explicitly tell it to not update etc.
        it
        (error "not a class")))
 
-(define StopIteration (list 'StopIteration))
+(define StopIteration 'StopIteration)
 (define-method (next (o <p>))
   (catch StopIteration
     (lambda () ((ref o '__next__)))