From 22e89b168a818681e5f92b7ae65c3d77ac1023f9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 19 Aug 2021 19:22:29 +0900 Subject: [PATCH] fix array-tile --- lib/srfi/179/test.sld | 107 ++++++++++++++++++------------------ lib/srfi/179/transforms.scm | 15 ++--- 2 files changed, 60 insertions(+), 62 deletions(-) diff --git a/lib/srfi/179/test.sld b/lib/srfi/179/test.sld index e32073e1..f6112de9 100644 --- a/lib/srfi/179/test.sld +++ b/lib/srfi/179/test.sld @@ -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 diff --git a/lib/srfi/179/transforms.scm b/lib/srfi/179/transforms.scm index dba734b5..55bc58a4 100644 --- a/lib/srfi/179/transforms.scm +++ b/lib/srfi/179/transforms.scm @@ -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)))))))