more pythonic assignments

1 files changed, 56 insertions, 26 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 694b470..3e16386 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -462,6 +462,11 @@
           (_ (error "unhandled addings")))
         (get-addings vs l))))))
   
+(define-syntax-rule (setwrap u)
+  (call-with-values (lambda () u)
+    (case-lambda
+      ((x) x)
+      (x x))))
 
 (define (make-set vs op x u)
   (define (tr-op op)
@@ -494,26 +499,31 @@
        (if kind
            (if (null? addings)                   
                (if op
-                   `(,s/d ,v (,(tr-op op) ,v ,u))
-                   `(,s/d ,v ,u))
+                   `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
+                   `(,s/d ,v (,(C 'setwrap) ,u)))
                (if op
                    `(,s/d ,(exp vs kind)
-                          (,(O 'fset-x) ,v (list ,@(map q addings))
-                           (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
+                           (,(O 'fset-x) ,v (list ,@(map q addings))
+                            (,(C 'setwrap)
+                             (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
                      
                    `(,s/d ,(exp vs kind)
-                          (,(O 'fset-x) ,v (list ,@(map q addings)) ,u))))
+                          (,(O 'fset-x) ,v (list ,@(map q addings))
+                           (,(C 'setwrap) ,u)))))
            
            (if (null? addings)
                (if op
-                   `(,s/d ,v (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))
-                   `(,s/d ,v ,u))
+                   `(,s/d ,v (,(C 'setwrap)
+                              (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
+                   `(,s/d ,v (,(C 'setwrap)
+                              ,u)))
                `(,(C 'set-x)
                  ,v
                  ,addings
-                 ,(if op
-                      `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
-                      u))))))))
+                 (,(C 'setwrap)
+                  ,(if op
+                       `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)
+                       u)))))))))
 
 (define (filter-defs x)
   (match (let lp ((x x))
@@ -1072,8 +1082,8 @@
   
 
  (#:expr-stmt
-  ((_ (l) (#:assign))
-   (exp vs l))
+  ((_ (l ...) (#:assign))
+   `(,(G 'values) ,@(map (g vs exp) l)))
    
   ((_ l type)
    (=> fail)
@@ -1089,17 +1099,35 @@
        (cond
         ((= (length l) (length u))
          (if (= (length l) 1)
-             (make-set vs op (car l) (exp vs (car u)))
-             (cons 'begin
-                   (map (lambda (l u) (make-set vs op l u))
-                        l
-                        (map (g vs exp) u)))))
-        ((and (= (length u) 1) (not op))
-         (let ((vars (map (lambda (x) (gensym "v")) l)))
-           `(call-with-values (lambda () (exp vs (car u)))
-              (lambda vars
-                ,@(map (lambda (l v) (make-set vs op l v))
-                       l vars)))))))))
+             `(begin
+                ,(make-set vs op (car l) (exp vs (car u)))
+                (values))
+             `(begin
+                @,(map (lambda (l u) (make-set vs op l u))
+                       l
+                       (map (g vs exp) u))
+                (values))))
+        
+        ((and (= (length u) 1) (not op))         
+         (let ((vars (map (lambda (x) (gensym "v")) l))
+               (q    (gensym "q"))
+               (f    (gensym "f")))
+           `(begin
+              (call-with-values (lambda () ,(exp vs (car u)))
+                (letrec ((,f
+                          (case-lambda
+                            ((,q)
+                             (apply ,f ,q))
+                            (,vars
+                             ,@(map (lambda (l v) (make-set vs op l v))
+                                    l vars)))))
+                  ,f))
+              (values))))
+        
+        ((and (= (length l) 1) (not op))
+         `(begin
+            ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u)))
+            (values)))))))
   
   ((_
     ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
@@ -1181,6 +1209,8 @@
      (C 'continue))
     (x x)))
 
+(define-syntax-rule (define- n x) (define! 'n x))
+
 (define (comp x)
   (define start
     (match (pr 'start x)
@@ -1202,12 +1232,12 @@
             (language python module ,@args)
             #:use-module (language python module python)))))
       (x '())))
-
+  
   (if (fluid-ref (@@ (system base compile) %in-compile))
       (with-fluids ((*prefixes* '()))             
         (if (fluid-ref (@@ (system base compile) %in-compile))
             (set! s/d 'set!)
-            (set! s/d 'define))
+            (set! s/d (C 'define-)))
   
         (if (pair? start)
             (set! x (cdr x)))
@@ -1222,7 +1252,7 @@
       (begin
         (if (fluid-ref (@@ (system base compile) %in-compile))
             (set! s/d 'set!)
-            (set! s/d 'define))
+            (set! s/d (C 'define-)))
   
         (if (pair? start)
             (set! x (cdr x)))