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 copying reshape.

Browse source 
Closes #986.
This commit is contained in:
Alex Shinn 2024-05-31 09:50:07 +09:00
parent 4b5ab838e2
commit 0b55c0b718
2 changed files with 26 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -3767,12 +3767,13 @@
'#(1 1 2 1)) '#(1 1 2 1))
(make-interval '#(4)))) (make-interval '#(4))))
'(test #t (test '((0 0) (0 1) (0 2) (0 3) (2 0) (2 1) (2 2) (2 3))
(array->list*
(specialized-array-reshape (specialized-array-reshape
(array-sample (array-copy (make-array (make-interval '#(3 4)) list)) (array-sample (array-copy (make-array (make-interval '#(3 4)) list))
'#(2 1)) '#(2 1))
(make-interval '#(8)) (make-interval '#(8))
#t)) #t)))
(test '(() ()) (test '(() ())
(array->list* (array->list*
(specialized-array-reshape (specialized-array-reshape

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

@ -514,6 +514,24 @@
(array-domain source)) (array-domain source))
destination))) destination)))
(define (array-assign/reshape! destination source)
(let ((dest-domain (array-domain destination))
(source-domain (array-domain source)))
(assert (and (mutable-array? destination) (array? source)
(= (interval-volume dest-domain)
(interval-volume source-domain))))
(let ((getter (array-getter source))
(setter (array-setter destination)))
(let lp ((source-ivc (interval-cursor source-domain))
(dest-ivc (interval-cursor dest-domain)))
(apply setter
(apply getter (interval-cursor-get source-ivc))
(interval-cursor-get dest-ivc))
(when (and (interval-cursor-next! source-ivc)
(interval-cursor-next! dest-ivc))
(lp source-ivc dest-ivc)))
destination)))
(define (reshape-without-copy array new-domain) (define (reshape-without-copy array new-domain)
(let* ((domain (array-domain array)) (let* ((domain (array-domain array))
(orig-indexer (array-indexer array)) (orig-indexer (array-indexer array))
@ -568,7 +586,7 @@
new-domain new-domain
(array-storage-class array) (array-storage-class array)
(array-safe? array)))) (array-safe? array))))
(array-assign! res array) (array-assign/reshape! res array)
res)) res))
(else (else
(error "can't reshape" array new-domain))))) (error "can't reshape" array new-domain)))))