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)))
(test-error (apply (array-getter B) index))))
;; (do ((i 0 (fx+ i 1)))
;; ((fx=? i tests))
;; (let* ((domain
;; (random-interval))
;; (array
;; (let ((res (make-array domain list)))
;; (case (random-integer 3)
;; ;; immutable
;; ((0) res)
;; ;; specialized
;; ((1) (array-copy res))
;; (else
;; ;; mutable, but not specialized
;; (let ((res (array-copy res)))
;; (make-array domain
;; (array-getter res)
;; (array-setter res)))))))
;; (lowers
;; (%%interval-lower-bounds domain))
;; (uppers
;; (%%interval-upper-bounds domain))
;; (sidelengths
;; (vector-map (lambda (l u)
;; (let ((dim (- u l)))
;; (random 1 (ceiling-quotient (* dim 7) 5))))
;; lowers uppers))
;; (result
;; (array-tile array sidelengths))
;; (test-result
;; (my-array-tile array sidelengths)))
(do ((i 0 (fx+ i 1)))
((fx=? i tests))
(let* ((domain
(random-interval))
(array
(let ((res (make-array domain list)))
(case (random-integer 3)
;; immutable
((0) res)
;; specialized
((1) (array-copy res))
(else
;; mutable, but not specialized
(let ((res (array-copy res)))
(make-array domain
(array-getter res)
(array-setter res)))))))
(lowers
(interval-lower-bounds->vector domain))
(uppers
(interval-upper-bounds->vector domain))
(sidelengths
(vector-map (lambda (l u)
(let ((dim (- u l)))
(random 1 (ceiling-quotient (* dim 7) 5))))
lowers uppers))
(result
(array-tile array sidelengths))
(test-result
(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-assert
;; (array-every (lambda (r t)
;; (equal? (array-domain r) (array-domain t)))
;; result test-result))
;; ;; test that the subarrays are the same type
;; (test-assert
;; (array-every
;; (lambda (r t)
;; (and
;; (eq? (mutable-array? r) (mutable-array? t))
;; (eq? (mutable-array? r) (mutable-array? array))
;; (eq? (specialized-array? r) (specialized-array? t))
;; (eq? (specialized-array? r) (specialized-array? array))))
;; result test-result))
;; ;; test that the first tile has the right values
;; (test-assert
;; (myarray= (apply (array-getter result)
;; (make-list (vector-length lowers) 0))
;; (apply (array-getter test-result)
;; (make-list (vector-length lowers) 0))))
;; ))
;; test all the subdomain tiles are the same
(test-assert
(array-every (lambda (r t)
(equal? (array-domain r) (array-domain t)))
result test-result))
;; test that the subarrays are the same type
(test-assert
(array-every
(lambda (r t)
(and
(eq? (mutable-array? r) (mutable-array? t))
(eq? (mutable-array? r) (mutable-array? array))
(eq? (specialized-array? r) (specialized-array? t))
(eq? (specialized-array? r) (specialized-array? array))))
result test-result))
;; test that the first tile has the right values
(test-assert
(myarray= (apply (array-getter result)
(make-list (vector-length lowers) 0))
(apply (array-getter test-result)
(make-list (vector-length lowers) 0))))
))
(test-error (array-reverse 'a 'a))
(test-error

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

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