Fix reshape zero-dimensional and empty arrays.

Issue #986.
ashinn · May 30, 2024 · 414a231 · 414a231
1 parent 5e74c5f
commit 414a231
Show file tree

Hide file tree

Showing 3 changed files with 65 additions and 42 deletions.
diff --git a/lib/srfi/231/base.scm b/lib/srfi/231/base.scm
@@ -447,27 +447,27 @@
 ;; possible multi-indices in domain in lexicographic order would
 ;; produce 0 through volume-1).
 (define (invert-default-index domain raw-index)
-  (let lp ((index raw-index)
-           (i 0)
-           (scale (/ (interval-volume domain)
-                     (max 1
-                          (- (interval-upper-bound domain 0)
-                             (interval-lower-bound domain 0)))))
-           (res '()))
-    (cond
-     ((>= (+ i 1) (interval-dimension domain))
-      (reverse (cons (+ index (interval-lower-bound domain i)) res)))
-     (else
-      (let ((digit (quotient index scale)))
-        (lp (- index (* digit scale))
-            (+ i 1)
-            (/ scale
-               (max 1
-                    (- (interval-upper-bound domain (+ i 1))
-                       (interval-lower-bound domain (+ i 1)))))
-            (cons (+ digit
-                     (interval-lower-bound domain i))
-                  res)))))))
+  (cond
+   ((or (zero? (interval-dimension domain)) (interval-empty? domain))
+    (interval-lower-bounds->list domain))
+   (else
+    (let lp ((index raw-index)
+             (i 0)
+             (scale (/ (interval-volume domain)
+                       (max 1 (interval-width domain 0))))
+             (res '()))
+      (cond
+       ((>= (+ i 1) (interval-dimension domain))
+        (reverse (cons (+ index (interval-lower-bound domain i)) res)))
+       (else
+        (let ((digit (quotient index scale)))
+          (lp (- index (* digit scale))
+              (+ i 1)
+              (/ scale
+                 (max 1 (interval-width domain (+ i 1))))
+              (cons (+ digit
+                       (interval-lower-bound domain i))
+                    res)))))))))
 
 ;; Specialized arrays
 

diff --git a/lib/srfi/231/test.sld b/lib/srfi/231/test.sld
@@ -3766,6 +3766,26 @@
             '#(#f #f #t #t))
            '#(1 1 2 1))
           (make-interval '#(4))))
+
+        '(test #t
+            (specialized-array-reshape
+             (array-sample (array-copy (make-array (make-interval '#(3 4)) list))
+                           '#(2 1))
+             (make-interval '#(8))
+             #t))
+        (test '(() ())
+            (array->list*
+             (specialized-array-reshape
+              (make-specialized-array (make-interval '#(1 2 0 4)))
+              (make-interval '#(2 0 4)))))
+        (test 'foo
+            (array->list*
+             (specialized-array-reshape ;; Reshape to a zero-dimensional array
+              (array-extract            ;; Restrict to the first element
+               (make-specialized-array-from-data  ;; One-dimensional array
+                (vector 'foo 'bar 'baz))
+               (make-interval '#(1)))
+              (make-interval '#()))))
         )
 
       (test-group "curry tests"

diff --git a/lib/srfi/231/transforms.scm b/lib/srfi/231/transforms.scm
@@ -525,33 +525,36 @@
                                          (apply tmp-indexer multi-index)))))
          (new-coeffs (indexer->coeffs new-indexer new-domain #t))
          (flat-indexer (coeffs->indexer new-coeffs new-domain))
-         (new-indexer (coeffs->indexer new-coeffs new-domain))
          (body (array-body array))
          (storage (array-storage-class array))
          (res
           (%make-specialized new-domain storage body new-coeffs flat-indexer
                              (array-safe? array) (array-setter array)
                              (array-adjacent? array))))
-    (let ((multi-index (interval-lower-bounds->list domain))
-          (orig-default-indexer (default-indexer domain)))
-      (let lp ((i 0)
-               (ls multi-index))
-        (let ((reshaped-index
-               (invert-default-index
-                new-domain
-                (apply orig-default-indexer multi-index))))
-          (cond
-           ((not (equal? (apply flat-indexer reshaped-index)
-                         (apply orig-indexer multi-index)))
-            #f)
-           ((null? ls)
-            res)
-           ((= (+ 1 (interval-lower-bound domain i))
-               (interval-upper-bound domain i))
-            (lp (+ i 1) (cdr ls)))
-           (else
-            (set-car! ls (+ 1 (car ls)))
-            (lp (+ i 1) (cdr ls)))))))))
+    (cond
+     ((interval-empty? new-domain)
+      (and (interval-empty? domain) res))
+     (else
+      (let ((multi-index (interval-lower-bounds->list domain))
+            (orig-default-indexer (default-indexer domain)))
+        (let lp ((i 0)
+                 (ls multi-index))
+          (let ((reshaped-index
+                 (invert-default-index
+                  new-domain
+                  (apply orig-default-indexer multi-index))))
+            (cond
+             ((not (equal? (apply flat-indexer reshaped-index)
+                           (apply orig-indexer multi-index)))
+              #f)
+             ((null? ls)
+              res)
+             ((= (+ 1 (interval-lower-bound domain i))
+                 (interval-upper-bound domain i))
+              (lp (+ i 1) (cdr ls)))
+             (else
+              (set-car! ls (+ 1 (car ls)))
+              (lp (+ i 1) (cdr ls)))))))))))
 
 (define (specialized-array-reshape array new-domain . o)
   (assert (and (specialized-array? array)