python loop macro for scheme using python modules
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 13 Sep 2017 20:29:12 +0000 (22:29 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Wed, 13 Sep 2017 20:29:12 +0000 (22:29 +0200)
modules/language/python/for.scm [new file with mode: 0644]

diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm
new file mode 100644 (file)
index 0000000..47f6992
--- /dev/null
@@ -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))