improved for loop methodology

1 files changed, 238 insertions, 6 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 565fdcf..7785195 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -1,5 +1,8 @@
 (define-module (language python compile)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
@@ -33,7 +36,7 @@
   (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
   (with-output-to-port port
     (lambda ()
-      (pretty-print x)))
+      (pretty-print (syntax->datum x))))
   (close port)
   (car (reverse x)))
 
@@ -290,6 +293,11 @@
                              ())))))))
                           
        
+    (#:break
+     (C 'break))
+    
+    (#:continue
+     (C 'continue))
     
     ((#:for e in code . #f)
      (=> next)
@@ -349,7 +357,16 @@
              (_ (next))))
           (_ (next))))
        (_ (next))))
-    
+
+    ((#:for es in code . else)
+     (let* ((es2   (map (g vs exp) es))
+            (vs2   (union es2 vs))
+            (code2 (exp vs2 code))
+            (p     (is-ec #t code2 #t (list (C 'break) (C 'continue))))
+            (else2 (if else (exp vs2 else) #f))
+            (in2   (map (g vs exp) in)))
+       (list (C 'for) es2 in2 code2 else2 p)))
+           
     ((#:while test code else)
      (let ((lp (gensym "lp")))
        `(let ,lp ()
@@ -518,6 +535,68 @@
        ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
        ,@(map (g globs exp) x))))
 
+(define-syntax-parameter break
+  (lambda (x) #'(values)))
+
+(define-syntax-parameter continue
+  (lambda (x) (error "continue must be bound")))
+
+(define-syntax-rule (with-sp ((x v) ...) code ...)
+  (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...))
+
+(define (is-ec ret x tail tags)
+  (syntax-case (pr 'is-ec x) (begin let if define @@)
+    ((begin a ... b)
+     #t
+     (or
+      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
+      (is-ec ret #'b tail tags)))
+    
+    ((let lp ((y x) ...) a ... b)
+     (symbol? (syntax->datum #'lp))
+     (or
+      (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
+      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
+      (is-ec ret #'b tail tags)))
+        
+    ((let ((y x) ...) a ... b)
+     #t
+     (or
+      (or-map (lambda (x) (is-ec ret x #f tags)) #'(x ...))
+      (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...))
+      (is-ec ret #'b tail tags)))
+        
+    ((if p a b)
+     #t
+     (or
+      (is-ec ret #'p #f   tags)
+      (is-ec ret #'a tail tags)
+      (is-ec ret #'b tail tags)))
+    
+    ((define . _)
+     #t
+     #f)
+    
+    ((if p a)
+     #t
+     (or
+      (is-ec ret #'p #f   tags)
+      (is-ec ret #'a tail tags)))
+    
+    ((@@ _ _)
+     #t
+     (if (member (pr (syntax->datum x)) tags)
+         #t
+         #f))
+    
+    ((a ...)
+     #t
+     (or-map (lambda (x) (is-ec ret x #f tags)) #'(a ...)))
+    
+    (x
+     #t
+     #f)))
+
 (define-syntax with-return
   (lambda (x)
     (define (analyze ret x)
@@ -539,9 +618,9 @@
              #'a
              #`(values a b ...)))
         (x #'x)))
-
+   
     (define (is-ec ret x tail)
-      (syntax-case x (begin let)
+      (syntax-case x (begin let if define @@)
         ((begin a ... b)
          #t
          (or
@@ -561,13 +640,18 @@
           (or-map (lambda (x) (is-ec ret x #f)) #'(x ...))
           (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))
           (is-ec ret #'b tail)))
-        
+
+        ((define . _)
+         #t
+         #f)
+
         ((if p a b)
          #t
          (or
           (is-ec ret #'p #f)
           (is-ec ret #'a tail)
           (is-ec ret #'b tail)))
+        
         ((if p a)
          #t
          (or
@@ -577,7 +661,7 @@
         ((return a b ...)
          (equal? (syntax->datum #'return) (syntax->datum ret))
          (not tail))
-
+        
         ((a ...)
          #t
          (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)))
@@ -600,3 +684,151 @@
         (values)
         (define! 'v #f))))
 
+(define-inlinable (non? x) (eq? x #:nil))
+
+(define-syntax for
+  (syntax-rules ()
+    ((_ (x) (a) code #f #f)
+     (if (pair? a)
+         (let lp ((l a))
+           (if (pair? l)
+               (let ((x (car l)))
+                 (with-sp ((continue (lp (cdr l)))
+                           (break    (values)))                          
+                          code
+                          (lp (cdr l))))))
+         (for/adv1 (x) (a) code #f #f)))
+
+    ((_ (x) (a) code #f #t)
+     (if (pair? a)
+         (let/ec break-ret
+           (let lp ((l a))
+             (if (pair? l)
+                 (begin
+                   (let/ec continue-ret
+                     (let ((x (car l)))
+                       (with-sp ((continue (continue-ret))
+                                 (break    (break-ret)))                     
+                         code)))
+                   (lp (cdr l))))))
+         (for/adv1 (x) (a) code #f #t)))
+
+    ((_ (x) (a) code next #f)
+     (if (pair? a)
+         (let/ec break-ret
+         (let ((x (let lp ((l a) (old #f))
+                    (if (pair? l)
+                        (let ((x (car l)))
+                          (with-sp ((continue (lp (cdr l) x))
+                                    (break    (break-ret)))
+                              code
+                              (lp (cdr l))))
+                        old))))
+           next)
+         (for/adv1 (x) (a) code next #f)))
+    
+    ((_ x a code next p)
+     (for/adv1 x a code next p))))
+
+(define-syntax for/adv1
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (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)))))))))
+
+      ((_ (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))))))))))
+
+      ((_  (x ...) in code else #f)
+       #'(for-adv (x ...) in code else #f))
+
+      ((_ (x ...) in code else #t)
+       #'(for-adv (x ...) in code else #t)))))
+
+
+(define-syntax for-adv
+  (lambda (x)
+    (define (gen x y)
+      (if (= (length (syntax->datum x)) (= (length (syntax->datum y))))
+          (syntax-case x ()
+            ((x ...) #'(values (next x) ...)))
+          (syntax-case x ()
+            ((x)  #'(next x)))))
+    
+    (syntax-case x ()
+      ((_ (x ...) (in ...) code else p)
+       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))          
+       (with-syntax ((get      (gen #'(inv ...) #'(x ...)))
+                     ((xx ...) (generate-temporaries #'(x ...))))
+         #'(let ((inv (wrap-in in)) ...)
+             (if p
+                 (let/ec break-ret
+                   (call-with-values
+                       (lambda ()
+                         (let lp ((xx #f) ...)
+                           (call-with-values (lambda () get)
+                             (lambda (x ...)
+                               (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
+                       (lambda ()
+                         (let lp ((xx #f) ...)
+                           (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)))))))))))
+    
+
+(define-class <scm-list> () (x) l)
+
+(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)))
+
+(define (wrap-in x)
+  (if (pair? x)
+      (let ((o (make <scm-list>)))
+        (slot-set! o 'l x)
+        o)
+      x))
+