diff --git a/lib/srfi/231/base.scm b/lib/srfi/231/base.scm index 50b12a1b..b329a585 100644 --- 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 index 96d40486..9a6d5ee1 100644 --- 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 index 3a1e83ed..d3bc4603 100644 --- 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)