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`.

---
 doc/ref/guile/util.texi | 15 +++++++++++++--
 module/hnh/util.scm     | 36 ++++++++++++++++++++++++++++++------
 tests/test/util.scm     | 33 ++++++++++++++++++++++++---------
 3 files changed, 67 insertions(+), 17 deletions(-)

diff --git a/doc/ref/guile/util.texi b/doc/ref/guile/util.texi
index 7536a9bc..95af9038 100644
--- a/doc/ref/guile/util.texi
+++ b/doc/ref/guile/util.texi
@@ -34,8 +34,8 @@ our extra specialized @var{when}}, but binds the return of
 @defmacx for (key ...) in collection body ...
 Syntactic sugar over @code{map}.
 @example
-for x in collection
-    body ...
+(for x in collection
+     body ...)
 @end example
 expands into
 @example
@@ -44,6 +44,17 @@ expands into
 
 If keys are a list, an match-lambda is used instead.
 @xref{Pattern Matching,,,guile}
+
+@defun break args ...
+Abandon the entire loop. Returing what was given to @code{break}.
+@end defun
+
+@defun continue [arg]
+Abandon the current iteration of the loop. If an argument is given,
+it's used as the result in the resulting list, otherwise @code{#f} is
+used.
+@end defun
+
 @end defmac
 
 
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>)))))))
 
 
 
diff --git a/tests/test/util.scm b/tests/test/util.scm
index 719afbed..b25c9add 100644
--- a/tests/test/util.scm
+++ b/tests/test/util.scm
@@ -39,15 +39,30 @@
   (awhen (memv 0 '(1 2 3 4 5))
          (cdr it)))
 
-(test-equal "for simple"
-  (iota 10)
-  (for x in (iota 10)
-       x))
-
-(test-equal "for matching"
-  (iota 12)
-  (for (x c) in (zip (iota 12) (string->list "Hello, World"))
-       x))
+(test-group "for"
+ (test-equal "for simple"
+   (iota 10)
+   (for x in (iota 10)
+        x))
+
+ (test-equal "for matching"
+   (iota 12)
+   (for (x c) in (zip (iota 12) (string->list "Hello, World"))
+        x))
+
+ (test-equal "for break"
+   'x
+   (for x in (iota 10)
+        (break 'x)
+        (test-assert "This should never happen" #f)))
+
+ (test-equal "for continue"
+   '(x #f 2)
+   (for x in (iota 3)
+        (case x
+          ((0) (continue 'x))
+          ((1) (continue))
+          (else x)))))
 
 (test-equal "procedure label"
   120
-- 
cgit v1.2.3