Fix interval iteration for empty intervals.

Closes #959.
ashinn · May 24, 2024 · 89dd02d · 89dd02d
1 parent 0ce4614
commit 89dd02d
Show file tree

Hide file tree

Showing 2 changed files with 27 additions and 12 deletions.
diff --git a/lib/srfi/231/base.scm b/lib/srfi/231/base.scm
@@ -179,23 +179,27 @@
                      ((>= j end1) acc))))
            ((>= i end0) acc))))
     (else
-     (let ((ivc (interval-cursor iv)))
-       (let lp ((acc knil))
-         (let ((acc (kons acc (apply f (interval-cursor-get ivc)))))
-           (if (interval-cursor-next! ivc)
-               (lp acc)
-               acc)))))))
+     (if (interval-empty? iv)
+         knil
+         (let ((ivc (interval-cursor iv)))
+           (let lp ((acc knil))
+             (let ((acc (kons acc (apply f (interval-cursor-get ivc)))))
+               (if (interval-cursor-next! ivc)
+                   (lp acc)
+                   acc))))))))
 
 (define (interval-fold kons knil iv)
   (interval-fold-left list (lambda (acc idx) (apply kons acc idx)) knil iv))
 
 (define (interval-fold-right f kons knil iv)
-  (let ((ivc (interval-cursor iv)))
-    (let lp ()
-      (let ((item (apply f (interval-cursor-get ivc))))
-        (if (interval-cursor-next! ivc)
-            (kons item (lp))
-            (kons item knil))))))
+  (if (interval-empty? iv)
+      knil
+      (let ((ivc (interval-cursor iv)))
+        (let lp ()
+          (let ((item (apply f (interval-cursor-get ivc))))
+            (if (interval-cursor-next! ivc)
+                (kons item (lp))
+                (kons item knil)))))))
 
 (define (interval-for-each f iv)
   (interval-fold (lambda (acc . multi-index) (apply f multi-index)) #f iv)

diff --git a/lib/srfi/231/test.sld b/lib/srfi/231/test.sld
@@ -1142,6 +1142,13 @@
         (test-error (interval-for-each (lambda (x) x) 1))
         (test-error (interval-for-each 1 (make-interval '#(3) '#(4))))
 
+        (test '()
+            (let ((result '()))
+              (interval-for-each
+               (lambda i (set! result (cons i result)))
+               (make-interval '#(1 2 3) '#(2 2 4)))
+              result))
+
         (do ((i 0 (+ i 1)))
             ((= i tests))
           (let* ((lower (map (lambda (x) (random 10))
@@ -1318,6 +1325,10 @@
             (array-packed? (make-specialized-array (make-interval '#(1 2 3)
                                                                   '#(1 2 3))
                                                    f32-storage-class)))
+        (test-assert
+            (array-packed? (make-specialized-array (make-interval '#(1 2 3)
+                                                                  '#(2 2 4))
+                                                   f32-storage-class)))
 
         ;; all these are true, we'll have to see how to screw it up later.
         (do ((i 0 (+ i 1)))