From 5672d44892c4010cdfbdc46f5fb29259fa51e076 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 10 Sep 2023 17:07:56 +0200
Subject: Add `break` and `continue` support in `for`.

---
 module/hnh/util.scm | 36 ++++++++++++++++++++++++++++++------
 1 file changed, 30 insertions(+), 6 deletions(-)

(limited to 'module')

diff --git a/module/hnh/util.scm b/module/hnh/util.scm
index 6fe9b371..a6581158 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -5,6 +5,7 @@
   :use-module ((sxml fold) :select (fold-values))
   :use-module ((srfi srfi-9 gnu) :select (set-fields))
   :use-module ((ice-9 copy-tree) :select (copy-tree))
+  :use-module ((ice-9 control) :select (call/ec))
   :re-export (fold-values)
   :export (aif
            awhen
@@ -114,14 +115,37 @@
 
 
 
-(define-syntax for
-  (syntax-rules (in)
+(define-syntax (for stx)
+  (syntax-case stx (in)
     ((for (<var> <vars> ...) in <collection> b1 body ...)
-     (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...])
-          <collection>))
+     (with-syntax ((break (datum->syntax stx 'break))
+                   (continue (datum->syntax stx 'continue)))
+       #'(call/ec
+          (lambda (break)
+            (map ((@ (ice-9 match) match-lambda)
+                  [(<var> <vars> ...)
+                   (call/ec
+                    (lambda (raw-continue)
+                      (let ((continue
+                             (case-lambda
+                               (() #f)
+                               (args (apply raw-continue args)))))
+                        b1 body ...)))])
+                 <collection>)))))
+
     ((for <var> in <collection> b1 body ...)
-     (map (lambda (<var>) b1 body ...)
-          <collection>))))
+     (with-syntax ((break (datum->syntax stx 'break))
+                   (continue (datum->syntax stx 'continue)))
+       #'(call/ec
+          (lambda (break)
+            (map (lambda (<var>)
+                   (call/ec (lambda (raw-continue)
+                              (let ((continue
+                                     (case-lambda
+                                       (() #f)
+                                       (args (apply raw-continue args)))))
+                                b1 body ...))))
+                 <collection>)))))))
 
 
 
-- 
cgit v1.2.3