diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/compile.scm | 82 | ||||
-rw-r--r-- | modules/language/python/for.scm | 14 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 15 |
3 files changed, 82 insertions, 29 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))) diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm index 587b30e..f43b0c1 100644 --- a/modules/language/python/for.scm +++ b/modules/language/python/for.scm @@ -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 @@ -60,8 +61,17 @@ (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) ... ... diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index ef3b190..418c325 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -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))) @@ -210,6 +210,19 @@ (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)))))))))) |