simplified for
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 14 Sep 2017 22:41:57 +0000 (00:41 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 14 Sep 2017 22:41:57 +0000 (00:41 +0200)
modules/language/python/for.scm

index f23ce6e8c0bc83ff9464c2838637046a318e4fc0..bc0dfbf0e08ec17b7da39db6425923559a824372 100644 (file)
 (define-syntax-parameter break (lambda (x) #f))
 
 (define-syntax for
+  (syntax-rules (:)
+    ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin)
+     (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin))
+    
+    ((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin)
+     (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin))
+    
+    ((for ((x ... : E) ...) ((c n) ...) code ...)
+     (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values)))
+    
+    ((for lp ((x ... : E) ...) ((c n) ...) code ...)
+     (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values)))))
+    
+(define-syntax for-work
   (lambda (x)
-    (syntax-case x (:)
-      ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin)
+    (define (wrap-continue lp code)
+      (if (syntax->datum lp)
+          #`(lambda () (let/ec #,lp #,@code))
+          #`(lambda ()              #,@code)))
+      
+    (syntax-case x ()
+      ((for lp ((x ... : E) ...) ((c n) ...) (code ...) 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
+         #`(let/ec lp-break
              (syntax-parameterize ((break (lambda (z)
                                             (syntax-case z ()
                                               ((_ . l)
                        (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 ...))
+                           #,(wrap-continue #'lp #'(code ...))
                          lp)))
-                   (lambda q (values)))))))))))
-
+                   (lambda q fin))))))))))
 
 (define-class <scm-list>   () l)
 (define-class <scm-string> () s i)