From b7a250f952dd1bf957bf6a02c6001a47a387e319 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Wed, 13 Sep 2017 22:29:12 +0200 Subject: python loop macro for scheme using python modules --- modules/language/python/for.scm | 140 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 modules/language/python/for.scm diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm new file mode 100644 index 0000000..47f6992 --- /dev/null +++ b/modules/language/python/for.scm @@ -0,0 +1,140 @@ +(define-module (language python for) + #:use-module (oop pf-objects) + #:use-module (ice-9 control) + #:export (for break)) + +(eval-when (compile eval load) + (define (generate-temporaries2 x) + (map (lambda (x) (generate-temporaries x)) x))) + +(define-syntax-parameter break (lambda (x) #f)) + +(define-syntax for + (lambda (x) + (syntax-case x (:) + ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin) + (with-syntax (((It ...) (generate-temporaries #'(E ...))) + ((cc ...) (generate-temporaries #'(c ...))) + (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...))) + (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))) + #'(let/ec lp-break + (syntax-parameterize ((break (lambda (z) + (syntax-case z () + ((_ . l) + #'(lp-break . l)) + (_ #'lp-break))))) + + (let ((It E) ... (c n) ... (x 'None) ... ... (x1 #f) ... ...) + (catch StopIteration + (lambda () + (let lp ((cc c) ...) + (set! c cc) ... + (call-with-values + (lambda () (next It)) + (lambda (x2 ...) + (set! x1 x2) ...)) + ... + (set! x x1) + ... ... + (call-with-values + (lambda () code ...) + lp))) + (lambda q fin))))))) + + ((for ((x ... : E) ...) ((c n) ...) code ...) + (with-syntax (((It ...) (generate-temporaries #'(E ...))) + ((cc ...) (generate-temporaries #'(c ...))) + (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...))) + (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))) + #'(let/ec lp-break + (syntax-parameterize ((break (lambda (z) + (syntax-case z () + ((_ . l) + #'(lp-break . l)) + (_ #'lp-break))))) + + (let ((It E) ... (c n) ... (x 'None) ... ... (x1 #f) ... ...) + (catch StopIteration + (lambda () + (let lp ((cc c) ...) + (set! c cc) ... + (call-with-values + (lambda () (next It)) + (lambda (x2 ...) + (set! x1 x2) ...)) + ... + (set! x x1) + ... ... + (call-with-values + (lambda () code ...) + lp))) + (lambda q (values)))))))) + + ((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin) + (with-syntax (((It ...) (generate-temporaries #'(E ...))) + ((cc ...) (generate-temporaries #'(c ...))) + (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...))) + (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))) + #'(let/ec lp-break + (syntax-parameterize ((break (lambda (z) + (syntax-case z () + ((_ . l) + #'(lp-break . l)) + (_ #'lp-break))))) + + (let ((It E) ... (c n) ... (x 'None) ... ... (x1 #f) ... ...) + (catch StopIteration + (lambda () + (let lp ((cc c) ...) + (set! c cc) ... + (call-with-values + (lambda () (next It)) + (lambda (x2 ...) + (set! x1 x2) ...)) + ... + (set! x x1) + ... ... + (call-with-values + (lambda () (let/ec lp code ...)) + lp))) + (lambda q fin))))))) + + ((for lp ((x ... : E) ...) ((c n) ...) code ...) + (with-syntax (((It ...) (generate-temporaries #'(E ...))) + ((cc ...) (generate-temporaries #'(c ...))) + (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...))) + (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))) + #'(let/ec lp-break + (syntax-parameterize ((break (lambda (z) + (syntax-case z () + ((_ . l) + #'(lp-break . l)) + (_ #'lp-break))))) + + (let ((It E) ... (c n) ... (x 'None) ... ... (x1 #f) ... ...) + (catch StopIteration + (lambda () + (let lp ((cc c) ...) + (set! c cc) ... + (call-with-values + (lambda () (next It)) + (lambda (x2 ...) + (set! x1 x2) ...)) + ... + (set! x x1) + ... ... + (call-with-values + (lambda () (let/ec lp code ...)) + lp))) + (lambda q (values))))))))))) + + +#; +(pk + (for c ((x : (gen '(1 2 3)))) ((s 0)) + (pk x) + (if (> x 2) (c s)) + (+ s x) + + #:final + s)) -- cgit v1.2.3