textwrap compiles

1 files changed, 185 insertions, 120 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index c3e7142..577d794 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -213,11 +213,19 @@
       vs))
 
     ((#:for es in code . final)
-     (let ((vs (let lp ((es es))
-                 (match es
-                   (((#:power #f (#:tuple . l) . _))
-                    (lp l))
-                   (_ (union vs (map (g vs exp) es)))))))
+     (let ((vs (union
+                vs
+                (let lp ((es es))
+                  (match es
+                   (((#:sub . l) . u)
+                    (union (lp l) (lp u))) 
+                   (((#:power #f (#:tuple . l) . _) . u)
+                    (union (lp l) (lp u)))
+                   (((and (#:power . _) x) . u)
+                    (union (list (exp vs x)) (lp u)))
+                   ((e . es)
+                    (union (lp e) (lp es)))
+                   (() '()))))))
        (scope final (scope code vs))))
 
      
@@ -819,16 +827,24 @@
 
  (#:del
   ;;We don't delete variables
-  ((_  (#:power #f base () . #f))
-   '(void))
+  ((_  . l)
+   `(begin 
+      ,@(let lp ((l l))
+          (match l
+            (((#:power #f base () . #f) . l)
+             (cons `(set! ,(exp vs base) #f)
+                   (lp l)))
+   
   
-  ((_  (#:power #f base (l ... fin) . #f))
-   (let* ((f     (exp vs base))
-          (fast? (not (eq? f 'super)))
-          (add   (get-addings vs l fast?))
-          (fin   (get-addings vs (list fin) fast?)))
-         
-     `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin))))
+            (((#:power #f base (l ... fin) . #f) . ll)
+             (let* ((f     (exp vs base))
+                    (fast? (not (eq? f 'super)))
+                    (add   (get-addings vs l fast?))
+                    (fin   (get-addings vs (list fin) fast?)))
+               (cons
+                `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin)
+                (lp ll))))
+            (() '()))))))
 
  (#:with
   ((_ (l ...) code)
@@ -1033,7 +1049,10 @@
                (else2 (if else (exp vs2 else) #f))
                (in2   (map (g vs exp) in)))
           (list (C 'cfor) es2 in2 code2 else2 p)))))))
- 
+
+ (#:sub
+  ((_ l)
+   (map (g vs exp) l)))
 
  (#:while
   ((_ test code . #f)
@@ -1044,7 +1063,7 @@
                  ,(exp vs code)
                  (,lp))))))
 
-  ((_ test code else)
+  ((_ test code . else)
    (let ((lp (gensym "lp")))
      `(let ,lp ()
            (if test
@@ -1499,7 +1518,7 @@
              ,@start
              ,(C 'clear-warning-data)
              (fluid-set! (@@ (system base message) %dont-warn-list) '())
-	     (define ,(C 'fnm) (make-hash-table))
+	     (define ,fnm (make-hash-table))
              ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
              ,@(map (g globs exp) x)
              (,(C 'export-all)))))
@@ -1700,12 +1719,21 @@
 
 (define (gentemp stx) (datum->syntax stx (gensym "x")))
 
+(define-syntax mmatch
+  (syntax-rules ()
+    ((_ (a . aa) (b . bb) . code)
+     (match a (b (mmatch aa bb . code))))
+    ((_ () () . code)
+     (begin . code))))
+
 (define-syntax clambda
   (lambda (x)
     (syntax-case x ()
       ((_ (x ...) code ...)
-       (with-syntax ((n (length #'(x ...))))
-         #'(let ((f (lambda (x ... . u) code ...)))
+       (with-syntax ((n (length #'(x ...)))
+                     ((y ...) (generate-temporaries #'(x ...))))
+         #'(let ((f (lambda (y ... . u)
+                      (mmatch (y ...) (x ...) code ...))))
              (if (> n 1)                
                  (case-lambda
                    ((c)
@@ -1719,63 +1747,68 @@
                  f)))))))
 
 (define-syntax cfor
-  (syntax-rules ()
-    ((_ (x) (a) code #f #f)
-     (if (pair? a)
-         (let/ec break-ret
-           (let lp ((l a))
-             (if (pair? l)
-                 (begin
-                   (set! x (car l))
-                   (with-sp ((continue (values))
-                             (break    (break-ret)))
-                            code)
-                   (lp (cdr l))))))
-         (for/adv1 (x) (a) code #f #f)))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (x ...) in code next p)
+       (or-map pair? #'(x ...))
+       #'(for-adv  (x ...) in code next p))
+     
+      ((_ (x) (a) code #f #f)
+       #'(if (pair? a)
+             (let/ec break-ret
+               (let lp ((l a))
+                 (if (pair? l)
+                     (begin
+                       (set! x (car l))
+                       (with-sp ((continue (values))
+                                 (break    (break-ret)))
+                                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)
-                 (let/ec continue-ret
-                   (set! x (car l))
-                   (with-sp ((continue (continue-ret))
-                             (break    (break-ret)))                     
-                            code))
-                 (lp (cdr l)))))
-         (for/adv1 (x) (a) code #f #t)))
+     #'(if (pair? a)
+           (let/ec break-ret
+             (let lp ((l a))
+               (if (pair? l)
+                   (let/ec continue-ret
+                     (set! 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 lp ((l a))
-             (if (pair? l)
-                 (begin
-                   (set! x (car l))
-                   (with-sp ((continue (values))
-                             (break    (break-ret)))
-                      code))
-                 (lp (cdr l))))
-           next)
-         (for/adv1 (x) (a) code next #f)))
+     #'(if (pair? a)
+           (let/ec break-ret
+             (let lp ((l a))
+               (if (pair? l)
+                   (begin
+                     (set! x (car l))
+                     (with-sp ((continue (values))
+                               (break    (break-ret)))
+                              code))
+                   (lp (cdr l))))
+             next)
+           (for/adv1 (x) (a) code next #f)))
 
     ((_ (x) (a) code next #t)
-     (if (pair? a)
-         (let/ec break-ret
-           (let lp ((l a))
-             (if (pair? l)
-                 (let/ec continue-ret
-                   (set! x (car l))
-                   (with-sp ((continue (continue-ret))
-                             (break    (break-ret)))
-                      code))
-                 (lp (cdr l))))
-           next)
-         (for/adv1 (x) (a) code next #f)))
+     #'(if (pair? a)
+           (let/ec break-ret
+             (let lp ((l a))
+               (if (pair? l)
+                   (let/ec continue-ret
+                     (set! x (car l))
+                     (with-sp ((continue (continue-ret))
+                               (break    (break-ret)))
+                              code))
+                   (lp (cdr l))))
+             next)
+           (for/adv1 (x) (a) code next #f)))
     
     ((_ x a code next p)
-     (for/adv1 x a code next p))))
+     #'(for/adv1 x a code next p)))))
 
 (define-syntax for/adv1
   (lambda (x)
@@ -1863,75 +1896,107 @@
             ((x ...) #'(values (next x) ...)))
           (syntax-case x ()
             ((x)  #'(next x)))))
+
+    (define (gen-temp x)
+      (syntax-case x ()
+        ((x ...) (map gen-temp #'(x ...)))
+        (x       (car (generate-temporaries (list #'x))))))
     
     (syntax-case x ()
       ((_ (x ...) (in) code else p)
        (with-syntax ((inv (gentemp #'in)))
-         (with-syntax (((xx ...) (generate-temporaries #'(x ...))))
+         (with-syntax (((xx ...) (gen-temp #'(x ...))))
            (if (syntax->datum #'p)
-               #'(let ((inv (wrap-in in)))               
+               #'(let ((inv (wrap-in in)))
+                   (clet (x ...)
+                     (let/ec break-ret
+                       (catch StopIteration
+                         (lambda ()
+                           (let lp ()
+                             (call-with-values (lambda () (next inv))
+                               (clambda (xx ...)
+                                 (cset! x xx) ...
+                                 (let/ec continue-ret
+                                   (with-sp ((break     (break-ret))
+                                             (continue  (continue-ret)))
+                                            code))
+                                 (lp)))))
+                         (lambda q else)))))
+             
+                   #'(let ((inv (wrap-in in)))
+                       (clet (x ...)
+                             (let/ec break-ret
+                               (catch StopIteration
+                                 (lambda ()
+                                   (let lp ()
+                                     (call-with-values (lambda () (next inv))
+                                       (clambda (xx ...)
+                                                (cset! x xx) ...
+                                         (with-sp ((break     (break-ret))
+                                                   (continue  (values)))
+                                                  code)
+                                         (lp)))))
+                                 (lambda e else)))))))))
+      
+      ((_ (x ...) (in ...) code else p)
+       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
+       (with-syntax ((get       (gen #'(inv ...) #'(x ...)))
+                     ((xx ...)  (gen-temp #'(x ...))))
+         (if (syntax->datum #'p)
+             #'(clet (x ...)
+                 (let ((inv (wrap-in in)) ...)               
                    (let/ec break-ret
                      (catch StopIteration
                        (lambda ()
                          (let lp ()
-                           (call-with-values (lambda () (next inv))
+                           (call-with-values (lambda () get)
                              (clambda (xx ...)
-                               (set! x xx) ...
+                               (cset! x xx) ...
                                (let/ec continue-ret
                                  (with-sp ((break     (break-ret))
                                            (continue  (continue-ret)))
                                           code))
                                (lp)))))
-                       (lambda q else))))
-             
-               #'(let ((inv (wrap-in in)))
-                   (let/ec break-ret
-                     (catch StopIteration
-                       (lambda ()
-                         (let lp ()
-                           (call-with-values (lambda () (next inv))
-                             (clambda (xx ...)
-                               (set! x xx) ...
-                               (with-sp ((break     (break-ret))
-                                         (continue  (values)))
-                                        code)
-                               (lp)))))
-                       (lambda e else))))))))
-      
-      ((_ (x ...) (in ...) code else p)
-       (with-syntax (((inv ...) (generate-temporaries #'(in ...))))
-       (with-syntax ((get      (gen #'(inv ...) #'(x ...)))
-                     ((xx ...) (generate-temporaries #'(x ...))))
-         (if (syntax->datum #'p)
-             #'(let ((inv (wrap-in in)) ...)               
-                 (let/ec break-ret
-                   (catch StopIteration
-                     (lambda ()
-                       (let lp ()
-                         (call-with-values (lambda () get)
-                           (clambda (xx ...)
-                             (set! x xx) ...
-                             (let/ec continue-ret
-                               (with-sp ((break     (break-ret))
-                                         (continue  (continue-ret)))
-                                        code))
-                             (lp)))))
-                     (lambda q else))))
+                       (lambda q else)))))
              
-             #'(let ((inv (wrap-in in)) ...)
-                 (let/ec break-ret
-                   (catch StopIteration
-                     (lambda ()
-                       (let lp ()
-                         (call-with-values (lambda () get)
-                           (clambda (xx ...)
-                             (set! x xx) ...
-                             (with-sp ((break     (break-ret))
-                                       (continue  (values)))
-                                      code)
-                             (lp)))))
-                     (lambda e else)))))))))))
+                 #'(clet (x ...)
+                     (let ((inv (wrap-in in)) ...)
+                       (let/ec break-ret
+                         (catch StopIteration
+                           (lambda ()
+                             (let lp ()
+                               (call-with-values (lambda () get)
+                                 (clambda (xx ...)
+                                   (cset! x xx) ...
+                                   (with-sp ((break     (break-ret))
+                                             (continue  (values)))
+                                            code)
+                                   (lp)))))
+                           (lambda e else))))))))))))
+
+(define-syntax cset!
+  (syntax-rules ()
+    ((_ (a . aa) (b . bb))
+     (begin
+       (cset! a  b)
+       (cset! aa bb)))
+    ((_ () ())
+     (values))
+    ((_ a b)
+     (set! a b))))
 
+(define-syntax clet
+  (syntax-rules ()
+    ((_ ((a . l) . u) . code)
+     (clet (a l . u) . code))
+    ((_ (() . u) . code)
+     (clet u . code))    
+    ((_ (a . u) . code)
+     (let ((a #f))
+       (clet u . code)))
+    ((_ () . code)
+     (begin . code))))
+    
 (define-syntax def-wrap
   (lambda (x)
     (syntax-case x ()