ashinn / chibi-scheme

Official chibi-scheme repository
Other
1.2k stars 142 forks source link

SRFI 231: Fix interval-fold-left #975

Closed gambiteer closed 2 months ago

gambiteer commented 2 months ago

Check for empty intervals earlier:

diff --git a/lib/srfi/231/base.scm b/lib/srfi/231/base.scm
index 7c302e5d..27b3a755 100644
--- a/lib/srfi/231/base.scm
+++ b/lib/srfi/231/base.scm
@@ -162,25 +162,25 @@
          (values ivc (vector-ref ivc 0)))))

 (define (interval-fold-left f kons knil iv)
-  (case (interval-dimension iv)
-    ((1)
-     (let ((end (interval-upper-bound iv 0)))
-       (do ((i (interval-lower-bound iv 0) (+ i 1))
-            (acc knil (kons acc (f i))))
-           ((>= i end) acc))))
-    ((2)
-     (let ((end0 (interval-upper-bound iv 0))
-           (start1 (interval-lower-bound iv 1))
-           (end1 (interval-upper-bound iv 1)))
-       (do ((i (interval-lower-bound iv 0) (+ i 1))
-            (acc knil
-                 (do ((j start1 (+ j 1))
-                      (acc acc (kons acc (f i j))))
-                     ((>= j end1) acc))))
-           ((>= i end0) acc))))
-    (else
-     (if (interval-empty? iv)
-         knil
+  (if (interval-empty? iv)
+      knil
+      (case (interval-dimension iv)
+        ((1)
+         (let ((end (interval-upper-bound iv 0)))
+           (do ((i (interval-lower-bound iv 0) (+ i 1))
+                (acc knil (kons acc (f i))))
+               ((>= i end) acc))))
+        ((2)
+         (let ((end0 (interval-upper-bound iv 0))
+               (start1 (interval-lower-bound iv 1))
+               (end1 (interval-upper-bound iv 1)))
+           (do ((i (interval-lower-bound iv 0) (+ i 1))
+                (acc knil
+                     (do ((j start1 (+ j 1))
+                          (acc acc (kons acc (f i j))))
+                         ((>= 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)))))
ashinn commented 2 months ago

Thanks! I had fixed this locally a few minutes before :)