Fix array-append for non-zero based intervals.

Closes #972.

Author: ashinn

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)))))

lib/srfi/231/test.sld

@@ -3255,7 +3255,7 @@
                         (make-array (make-interval '#(2 3)) list)))
         )
 
-      (test-group "stack/block"
+      (test-group "stack/block/append"
         (let* ((a
                 (make-array (make-interval '#(4 10)) list))
                (a-column
@@ -3315,6 +3315,26 @@
                                  (list (list*->array 2 '((12 13)))
                                        (list*->array 2 '((14)))
                                        (list*->array 2 '((15 16 17)))))))))
+        (test-assert
+            (array-append
+             1
+             (list
+              (list->array
+               (make-interval (quote #(1 -9 -1 3))
+                              (quote #(5 -8 5 8)))
+               '(0 4 9 1 7 4 5 9 5 2 2 2 2 5 7 1 5 2 1 1 5 4 6 1 1 2 5 2 5 3 5 7 1 6 9 5 4 4 6 2 2 8 4 6 5 4 2 5 9 7 1 8 4 0 6 9 8 7 9 8 0 9 4 0 0 4 4 5 8 3 7 8 0 4 4 7 1 1 1 1 2 9 1 5 7 0 5 0 4 4 5 0 3 7 1 2 9 5 7 7 6 0 2 5 4 9 0 6 1 2 2 4 4 6 4 3 0 1 8 6))
+              (list->array
+               (make-interval (quote #(1 -8 -1 3))
+                              (quote #(5 -6 5 8)))
+               '(3 1 9 0 4 3 7 4 6 2 9 9 4 7 2 4 4 4 7 4 6 9 5 3 4 3 6 8 1 4 2 3 0 6 5 9 1 4 0 9 7 9 0 5 7 5 4 1 0 6 4 6 5 1 4 4 6 2 3 3 3 5 0 5 8 3 8 1 3 1 2 6 5 5 2 6 5 3 3 3 4 5 9 7 9 7 4 1 9 8 7 8 4 9 5 3 0 0 1 9 8 9 8 4 7 3 9 3 5 0 9 7 4 6 8 4 3 0 7 7 7 0 9 7 3 2 7 6 9 2 0 1 0 1 1 9 7 7 1 9 7 0 9 9 0 0 7 6 5 2 9 2 9 4 9 3 7 6 1 8 9 4 4 4 5 7 2 4 6 0 3 0 7 4 3 6 3 0 3 2 2 4 4 0 1 9 3 9 8 5 7 3 9 8 9 2 4 1 8 4 4 5 6 9 3 7 2 8 2 9 0 4 6 6 7 4 2 2 3 1 7 0 8 4 8 7 6 4 3 9 2 7 1 1 9 0 1 8 3 1))
+              (list->array
+               (make-interval (quote #(1 -6 -1 3))
+                              (quote #(5 -6 5 8)))
+               '())
+              (list->array
+               (make-interval (quote #(1 -6 -1 3))
+                              (quote #(5 -5 5 8)))
+               '(3 1 6 2 8 0 8 1 2 6 7 2 9 4 6 5 2 4 5 4 5 2 6 6 0 6 4 2 1 3 4 6 9 6 7 2 4 8 4 3 5 5 8 0 6 4 6 3 7 6 3 4 1 6 2 3 1 9 1 0 3 1 5 0 3 5 8 1 8 0 2 3 1 5 0 4 9 5 3 2 0 7 6 5 5 9 4 8 5 3 2 5 1 4 8 4 5 7 4 6 1 5 8 2 0 1 5 0 8 3 0 4 6 1 7 1 7 1 6 9)))))
         )
 
       '(test-group "assign/product"

lib/srfi/231/transforms.scm

@@ -452,20 +452,22 @@
   (apply list->array domain (vector->list vec) o))
 
 (define (array-assign! destination source)
-  (assert (and (mutable-array? destination) (array? source)
-               (interval= (array-domain destination) (array-domain source))))
-  (let ((getter (array-getter source))
-        (setter (array-setter destination)))
-    (interval-for-each
-     (case (array-dimension destination)
-       ((1) (lambda (i) (setter (getter i) i)))
-       ((2) (lambda (i j) (setter (getter i j) i j)))
-       ((3) (lambda (i j k) (setter (getter i j k) i j k)))
-       (else
-        (lambda multi-index
-          (apply setter (apply getter multi-index) multi-index))))
-     (array-domain source))
-    destination))
+  (let ((dest-domain (array-domain destination))
+        (source-domain (array-domain source)))
+    (assert (and (mutable-array? destination) (array? source)
+                 (interval= dest-domain source-domain)))
+    (let ((getter (array-getter source))
+          (setter (array-setter destination)))
+      (interval-for-each
+       (case (array-dimension destination)
+         ((1) (lambda (i) (setter (getter i) i)))
+         ((2) (lambda (i j) (setter (getter i j) i j)))
+         ((3) (lambda (i j k) (setter (getter i j k) i j k)))
+         (else
+          (lambda multi-index
+            (apply setter (apply getter multi-index) multi-index))))
+       (array-domain source))
+      destination)))
 
 (define (reshape-without-copy array new-domain)
   (let* ((domain (array-domain array))
@@ -612,7 +614,8 @@
                (pair? arrays)
                (every array? arrays)
                (< -1 axis (array-dimension (car arrays)))))
-  (let* ((a (car arrays))
+  (let* ((arrays (remove array-empty? arrays))
+         (a (car arrays))
          (a-domain (array-domain a))
          (storage (if (pair? o) (car o) generic-storage-class))
          (mutable? (if (and (pair? o) (pair? (cdr o)))
@@ -634,29 +637,32 @@
                          (vector-ref c-hi axis)
                          (cdr arrays)))
       (let* ((c-domain (make-interval c-lo c-hi))
-             (c (make-specialized-array/default c-domain storage safe?))
-             (b-trans (make-vector (array-dimension a) 0)))
+             (c (make-specialized-array/default c-domain storage safe?)))
         (array-assign!
          (array-extract c (make-interval c-lo (interval-widths a-domain)))
          (array-translate a (vector-map - a-lo)))
         (let lp ((arrays (cdr arrays))
                  (b-offset (- (interval-upper-bound a-domain axis)
                               (interval-lower-bound a-domain axis))))
-          (if (null? arrays)
-              (if mutable? c (array-freeze! c))
-              (let* ((b (car arrays))
-                     (b-domain (array-domain b))
-                     (b-offset2 (+ b-offset (interval-width b-domain axis)))
-                     (b-lo (make-vector (interval-dimension b-domain) 0))
-                     (b-hi (interval-widths b-domain)))
-                (vector-set! b-lo axis b-offset)
-                (vector-set! b-hi axis b-offset2)
-                (vector-set! b-trans axis (- b-offset))
-                (let ((view (array-translate
-                             (array-extract c (make-interval b-lo b-hi))
-                             b-trans)))
-                  (array-assign! view b)
-                  (lp (cdr arrays) b-offset2)))))))))
+          (cond
+           ((null? arrays)
+            (if mutable? c (array-freeze! c)))
+           (else
+            (let* ((b (car arrays))
+                   (b-domain (array-domain b))
+                   (b-offset2 (+ b-offset (interval-width b-domain axis)))
+                   (b-lo (make-vector (interval-dimension b-domain) 0))
+                   (b-hi (interval-widths b-domain)))
+              (vector-set! b-lo axis b-offset)
+              (vector-set! b-hi axis b-offset2)
+              (let ((dest-view (array-extract c (make-interval b-lo b-hi)))
+                    (b-trans
+                     (vector-map - (interval-lower-bounds->vector b-domain))))
+                (vector-set! b-trans axis (+ (vector-ref b-trans axis)
+                                             b-offset))
+                (array-assign! dest-view (array-translate b b-trans))
+                (lp (cdr arrays) b-offset2))
+              ))))))))
 
 (define array-append! array-append)