Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fix reshape zero-dimensional and empty arrays.

Browse source 
Issue #986.
This commit is contained in:
Alex Shinn 2024-05-30 22:37:06 +09:00
parent 5e74c5ff54
commit 414a23139f
3 changed files with 65 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
lib/srfi/231/base.scm
View file

@ -447,27 +447,27 @@
;; possible multi-indices in domain in lexicographic order would ;; possible multi-indices in domain in lexicographic order would
;; produce 0 through volume-1). ;; produce 0 through volume-1).
(define (invert-default-index domain raw-index) (define (invert-default-index domain raw-index)
(let lp ((index raw-index) (cond
(i 0) ((or (zero? (interval-dimension domain)) (interval-empty? domain))
(scale (/ (interval-volume domain) (interval-lower-bounds->list domain))
(max 1 (else
(- (interval-upper-bound domain 0) (let lp ((index raw-index)
(interval-lower-bound domain 0))))) (i 0)
(res '())) (scale (/ (interval-volume domain)
(cond (max 1 (interval-width domain 0))))
((>= (+ i 1) (interval-dimension domain)) (res '()))
(reverse (cons (+ index (interval-lower-bound domain i)) res))) (cond
(else ((>= (+ i 1) (interval-dimension domain))
(let ((digit (quotient index scale))) (reverse (cons (+ index (interval-lower-bound domain i)) res)))
(lp (- index (* digit scale)) (else
(+ i 1) (let ((digit (quotient index scale)))
(/ scale (lp (- index (* digit scale))
(max 1 (+ i 1)
(- (interval-upper-bound domain (+ i 1)) (/ scale
(interval-lower-bound domain (+ i 1))))) (max 1 (interval-width domain (+ i 1))))
(cons (+ digit (cons (+ digit
(interval-lower-bound domain i)) (interval-lower-bound domain i))
res))))))) res)))))))))
;; Specialized arrays ;; Specialized arrays

20
lib/srfi/231/test.sld
View file

@ -3766,6 +3766,26 @@
'#(#f #f #t #t)) '#(#f #f #t #t))
'#(1 1 2 1)) '#(1 1 2 1))
(make-interval '#(4)))) (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" (test-group "curry tests"

45
lib/srfi/231/transforms.scm
View file

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