more pythonic assignments
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Tue, 10 Oct 2017 22:55:55 +0000 (00:55 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Tue, 10 Oct 2017 22:55:55 +0000 (00:55 +0200)
modules/language/python/compile.scm
modules/language/python/for.scm
modules/language/python/module/python.scm

index 694b47007c6a4e0a32de87c30fcfc81360e513a9..3e16386a2a1c8bcea553703c4d1b75baf58385ed 100644 (file)
           (_ (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)
        (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))
   
 
  (#:expr-stmt
-  ((_ (l) (#:assign))
-   (exp vs l))
+  ((_ (l ...) (#:assign))
+   `(,(G 'values) ,@(map (g vs exp) l)))
    
   ((_ l type)
    (=> fail)
        (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))
      (C 'continue))
     (x x)))
 
+(define-syntax-rule (define- n x) (define! 'n x))
+
 (define (comp x)
   (define start
     (match (pr 'start x)
             (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)))
       (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)))
index 587b30e345bca2d5726eae7bd787165df1116047..f43b0c170110bc1edf66201c43120e55c4463073 100644 (file)
@@ -41,6 +41,7 @@
                      ((cc ...)       (generate-temporaries #'(c ...)))
                      (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...)))
                      (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))
+                     ((N ...)        (map length #'((x ...) ...)))
                      (llp            (if (syntax->datum #'lp) #'lp #'lpu)))
          
          #`(let/ec lp-break
                        (set! c cc) ...
                        (call-with-values
                            (lambda () (next It))
-                         (lambda (x2 ...)
-                           (set! x1 x2) ...))
+                         (let ((f
+                                (lambda (x2 ...)
+                                  (set! x1 x2) ...)))
+                           (if (> N 1)
+                               (case-lambda
+                                 ((q)
+                                  (apply f q))
+                                 (q
+                                  (apply f q)))
+                               (lambda (x2 ... . ll)
+                                 (set! x1 x2) ...))))
                        ...
                        (set! x x1)
                        ... ...
index ef3b190dad465a06cd22bad5a974e3f3b7fa2cdb..418c3252006a481ce9c6209a22691b24b6490a2c 100644 (file)
@@ -35,7 +35,7 @@
                   divmod enumerate filter format
                   getattr hasattr hex isinstance
                   iter map sum id input oct ord pow super
-                  sorted))
+                  sorted zip))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
   (pylist-sort! l #:key key #:reverse reverse)
   l)
 
+(define (zip . l)
+  (let ((l ((@ (guile) map) wrap-in l)))
+    ((make-generator ()
+      (lambda (yield)
+        (let lp ()
+          (let lp2 ((l l) (r '()))
+            (if (pair? l)
+                (call-with-values (lambda () (next (car l)))
+                  (lambda z
+                    (lp2 (cdr l) (append (reverse z) r))))
+                (begin
+                  (apply yield (reverse r))
+                  (lp))))))))))