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

fix array-tile

Browse source
This commit is contained in:
Alex Shinn 2021-08-19 19:22:29 +09:00
parent 57e4652ea6
commit 22e89b168a
2 changed files with 60 additions and 62 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

107
lib/srfi/179/test.sld
View file

@ -2865,61 +2865,62 @@ OTHER DEALINGS IN THE SOFTWARE.
(index (make-list d 12))) (index (make-list d 12)))
(test-error (apply (array-getter B) index)))) (test-error (apply (array-getter B) index))))
;; (do ((i 0 (fx+ i 1))) (do ((i 0 (fx+ i 1)))
;; ((fx=? i tests)) ((fx=? i tests))
;; (let* ((domain (let* ((domain
;; (random-interval)) (random-interval))
;; (array (array
;; (let ((res (make-array domain list))) (let ((res (make-array domain list)))
;; (case (random-integer 3) (case (random-integer 3)
;; ;; immutable ;; immutable
;; ((0) res) ((0) res)
;; ;; specialized ;; specialized
;; ((1) (array-copy res)) ((1) (array-copy res))
;; (else (else
;; ;; mutable, but not specialized ;; mutable, but not specialized
;; (let ((res (array-copy res))) (let ((res (array-copy res)))
;; (make-array domain (make-array domain
;; (array-getter res) (array-getter res)
;; (array-setter res))))))) (array-setter res)))))))
;; (lowers (lowers
;; (%%interval-lower-bounds domain)) (interval-lower-bounds->vector domain))
;; (uppers (uppers
;; (%%interval-upper-bounds domain)) (interval-upper-bounds->vector domain))
;; (sidelengths (sidelengths
;; (vector-map (lambda (l u) (vector-map (lambda (l u)
;; (let ((dim (- u l))) (let ((dim (- u l)))
;; (random 1 (ceiling-quotient (* dim 7) 5)))) (random 1 (ceiling-quotient (* dim 7) 5))))
;; lowers uppers)) lowers uppers))
;; (result (result
;; (array-tile array sidelengths)) (array-tile array sidelengths))
;; (test-result (test-result
;; (my-array-tile array sidelengths))) (my-array-tile array sidelengths)))
;; ;; extract-array is tested independently, so we just make a few tests. ;; extract-array is tested independently, so we just make
;; a few tests.
;; ;; test all the subdomain tiles are the same ;; test all the subdomain tiles are the same
;; (test-assert (test-assert
;; (array-every (lambda (r t) (array-every (lambda (r t)
;; (equal? (array-domain r) (array-domain t))) (equal? (array-domain r) (array-domain t)))
;; result test-result)) result test-result))
;; ;; test that the subarrays are the same type ;; test that the subarrays are the same type
;; (test-assert (test-assert
;; (array-every (array-every
;; (lambda (r t) (lambda (r t)
;; (and (and
;; (eq? (mutable-array? r) (mutable-array? t)) (eq? (mutable-array? r) (mutable-array? t))
;; (eq? (mutable-array? r) (mutable-array? array)) (eq? (mutable-array? r) (mutable-array? array))
;; (eq? (specialized-array? r) (specialized-array? t)) (eq? (specialized-array? r) (specialized-array? t))
;; (eq? (specialized-array? r) (specialized-array? array)))) (eq? (specialized-array? r) (specialized-array? array))))
;; result test-result)) result test-result))
;; ;; test that the first tile has the right values ;; test that the first tile has the right values
;; (test-assert (test-assert
;; (myarray= (apply (array-getter result) (myarray= (apply (array-getter result)
;; (make-list (vector-length lowers) 0)) (make-list (vector-length lowers) 0))
;; (apply (array-getter test-result) (apply (array-getter test-result)
;; (make-list (vector-length lowers) 0)))) (make-list (vector-length lowers) 0))))
;; )) ))
(test-error (array-reverse 'a 'a)) (test-error (array-reverse 'a 'a))
(test-error (test-error

15
lib/srfi/179/transforms.scm
View file

@ -132,15 +132,12 @@
(vector? sizes) (vector? sizes)
(= (array-dimension array) (vector-length sizes)) (= (array-dimension array) (vector-length sizes))
(vector-every exact-integer? sizes) (vector-every exact-integer? sizes)
(vector-every >= sizes (interval-lower-bounds->vector (vector-every <= sizes (interval-ub (array-domain array)))))
(array-domain array)))
(vector-every < sizes (interval-upper-bounds->vector
(array-domain array)))))
(let ((domain (make-interval (let ((domain (make-interval
(vector-map (vector-map
(lambda (lo hi s) (exact (ceiling (/ (- hi lo) s)))) (lambda (lo hi s) (exact (ceiling (/ (- hi lo) s))))
(interval-lower-bounds->vector (array-domain array)) (interval-lb (array-domain array))
(interval-upper-bounds->vector (array-domain array)) (interval-ub (array-domain array))
sizes)))) sizes))))
(make-array (make-array
domain domain
@ -150,13 +147,13 @@
(make-interval (make-interval
(vector-map (vector-map
(lambda (i lo s) (+ lo (* i s))) (lambda (i lo s) (+ lo (* i s)))
multi-index (list->vector multi-index)
(interval-lower-bound (array-domain array)) (interval-lb (array-domain array))
sizes) sizes)
(vector-map (vector-map
(lambda (i lo hi s) (lambda (i lo hi s)
(min hi (+ lo (* (+ i 1) s)))) (min hi (+ lo (* (+ i 1) s))))
multi-index (list->vector multi-index)
(interval-lb (array-domain array)) (interval-lb (array-domain array))
(interval-ub (array-domain array)) (interval-ub (array-domain array))
sizes))))))) sizes)))))))