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

Fix validation on specialized-array-reshape.

Browse source
This commit is contained in:
Alex Shinn 2021-04-30 13:38:53 +09:00
parent 76284f79f0
commit 3c138dc808
2 changed files with 126 additions and 98 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

176
lib/srfi/179.scm
View file

@ -265,7 +265,7 @@
array? array?
(domain array-domain) (domain array-domain)
(getter array-getter) (getter array-getter)
(setter array-setter) (setter array-setter %array-setter-set!)
(storage array-storage-class) (storage array-storage-class)
(body array-body) (body array-body)
(coeffs array-coeffs) (coeffs array-coeffs)
@ -326,19 +326,25 @@
(if (and verify? (zero? count)) (if (and verify? (zero? count))
(lp 1 multi-index offset (+ count 1)) (lp 1 multi-index offset (+ count 1))
res)) res))
((= (+ 1 (car ls)) (interval-upper-bound domain (- i 1))) ((= (+ 1 (interval-lower-bound domain (- i 1)))
(interval-upper-bound domain (- i 1)))
(lp (+ i 1) (cdr ls) offset count)) (lp (+ i 1) (cdr ls) offset count))
(else (else
(set-car! ls (+ 1 (car ls))) (let ((dir (if (and (> count 0)
(let* ((offset2 (apply indexer multi-index)) (= (+ (car ls) 1)
(coeff (- offset2 offset))) (interval-upper-bound domain (- i 1))))
(cond -1
((> count 0) 1)))
(and (= coeff (vector-ref res i)) (set-car! ls (+ (car ls) dir))
(lp (+ i 1) (cdr ls) offset2 count))) (let* ((offset2 (apply indexer multi-index))
(else (coeff (* dir (- offset2 offset))))
(vector-set! res i coeff) (cond
(lp (+ i 1) (cdr ls) offset2 count))))))))) ((> count 0)
(and (= coeff (vector-ref res i))
(lp (+ i 1) (cdr ls) offset2 count)))
(else
(vector-set! res i coeff)
(lp (+ i 1) (cdr ls) offset2 count))))))))))
(define (coeffs->indexer coeffs domain) (define (coeffs->indexer coeffs domain)
(case (vector-length coeffs) (case (vector-length coeffs)
@ -396,25 +402,47 @@
(define (default-indexer domain) (define (default-indexer domain)
(coeffs->indexer (default-coeffs domain) domain)) (coeffs->indexer (default-coeffs domain) domain))
;; converts the raw integer index to the multi-index in domain that ;; Converts the raw integer index to the multi-index in domain that
;; would map to it using the default indexer. ;; would map to it using the default indexer (i.e. iterating over the
;; possible multi-indices in domain in lexicographic order would
;; produce 0 through volume-1).
(define (invert-default-index domain raw-index) (define (invert-default-index domain raw-index)
(let lp ((index raw-index) (let lp ((index raw-index)
(i (- (interval-dimension domain) 1)) (i 0)
(scale 1) (scale (/ (interval-volume domain)
(max 1
(- (interval-upper-bound domain 0)
(interval-lower-bound domain 0)))))
(res '())) (res '()))
(if (negative? i) (cond
res ((>= (+ i 1) (interval-dimension domain))
(let* ((width (- (interval-upper-bound domain i) (reverse (cons (+ index (interval-lower-bound domain i)) res)))
(interval-lower-bound domain i))) (else
(elt (modulo index width))) (let ((digit (quotient index scale)))
(lp (quotient (- index elt) scale) (lp (- index (* digit scale))
(- i 1) (+ i 1)
(* scale width) (/ scale
(cons (+ elt (interval-lower-bound domain i)) res)))))) (max 1
(- (interval-upper-bound domain (+ i 1))
(interval-lower-bound domain (+ i 1)))))
(cons (+ digit
(interval-lower-bound domain i))
res)))))))
;; Specialized arrays ;; Specialized arrays
(define (%make-specialized domain storage body coeffs indexer safe? mutable?)
(%make-array
domain
(specialized-getter body indexer (storage-class-getter storage))
(and mutable?
(specialized-setter body indexer (storage-class-setter storage)))
storage
body
coeffs
indexer
safe?))
(define (make-specialized-array domain . o) (define (make-specialized-array domain . o)
(let* ((storage (if (pair? o) (car o) generic-storage-class)) (let* ((storage (if (pair? o) (car o) generic-storage-class))
(safe? (if (and (pair? o) (pair? (cdr o))) (safe? (if (and (pair? o) (pair? (cdr o)))
@ -426,15 +454,7 @@
(coeffs (default-coeffs domain)) (coeffs (default-coeffs domain))
(indexer (coeffs->indexer coeffs domain))) (indexer (coeffs->indexer coeffs domain)))
(assert (boolean? safe?)) (assert (boolean? safe?))
(%make-array (%make-specialized domain storage body coeffs indexer safe? #t)))
domain
(specialized-getter body indexer (storage-class-getter storage))
(specialized-setter body indexer (storage-class-setter storage))
storage
body
coeffs
indexer
safe?)))
(define (specialized-array? x) (define (specialized-array? x)
(and (array? x) (array-storage-class x) #t)) (and (array? x) (array-storage-class x) #t))
@ -468,15 +488,8 @@
(indexer (indexer
(coeffs->indexer coeffs new-domain)) (coeffs->indexer coeffs new-domain))
(storage (array-storage-class array))) (storage (array-storage-class array)))
(%make-array (%make-specialized new-domain storage body coeffs indexer
new-domain (array-safe? array) (array-setter array))))
(specialized-getter body indexer (storage-class-getter storage))
(specialized-setter body indexer (storage-class-setter storage))
storage
body
coeffs
indexer
(array-safe? array))))
;; Array transformations ;; Array transformations
@ -500,9 +513,12 @@
(storage-class-getter storage))) (storage-class-getter storage)))
(setter (specialized-setter body indexer (setter (specialized-setter body indexer
(storage-class-setter storage))) (storage-class-setter storage)))
(res (%make-array new-domain getter setter (res (%make-specialized new-domain storage body coeffs indexer
storage body coeffs indexer safe?))) safe? #t)))
(array-assign! res array)))) (array-assign! res array)
(unless mutable?
(%array-setter-set! res #f))
res)))
(define (array-curry array inner-dimension) (define (array-curry array inner-dimension)
(call-with-values (call-with-values
@ -814,16 +830,45 @@
(array-domain source)))) (array-domain source))))
destination)) destination))
(define (reshape-indexer array new-domain) (define (reshape-without-copy array new-domain)
(let ((orig-indexer (array-indexer array)) (let* ((domain (array-domain array))
(tmp-indexer (default-indexer new-domain))) (orig-indexer (array-indexer array))
(indexer->coeffs (tmp-indexer (default-indexer new-domain))
(lambda multi-index (new-indexer
(apply orig-indexer (lambda multi-index
(invert-default-index (array-domain array) (apply orig-indexer
(apply tmp-indexer multi-index)))) (invert-default-index domain
new-domain (apply tmp-indexer multi-index)))))
#t))) (new-coeffs
(indexer->coeffs new-indexer new-domain #t))
(flat-indexer
(coeffs->indexer new-coeffs new-domain))
(new-indexer (coeffs->indexer new-coeffs new-domain))
(body (array-body array))
(storage (array-storage-class array))
(res
(%make-specialized new-domain storage body new-coeffs flat-indexer
(array-safe? array) (array-setter array))))
(let ((multi-index (interval-lower-bounds->list domain))
(orig-default-indexer (default-indexer domain)))
(let lp ((i 0)
(ls multi-index))
(let ((reshaped-index
(invert-default-index
new-domain
(apply orig-default-indexer multi-index))))
(cond
((not (equal? (apply flat-indexer reshaped-index)
(apply orig-indexer multi-index)))
#f)
((null? ls)
res)
((= (+ 1 (interval-lower-bound domain i))
(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 (specialized-array? array) (assert (specialized-array? array)
@ -831,24 +876,7 @@
(interval-volume new-domain))) (interval-volume new-domain)))
(let ((copy-on-failure? (and (pair? o) (car o)))) (let ((copy-on-failure? (and (pair? o) (car o))))
(cond (cond
((reshape-indexer array new-domain) ((reshape-without-copy array new-domain))
=> (lambda (new-coeffs)
(let* ((new-indexer (coeffs->indexer new-coeffs new-domain))
(body (array-body array))
(storage (array-storage-class array)))
(%make-array
new-domain
(specialized-getter body
new-indexer
(storage-class-getter storage))
(specialized-setter body
new-indexer
(storage-class-setter storage))
storage
body
new-coeffs
new-indexer
(array-safe? array)))))
(copy-on-failure? (copy-on-failure?
(let* ((res (make-specialized-array (let* ((res (make-specialized-array
new-domain new-domain

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

@ -3406,33 +3406,33 @@ OTHER DEALINGS IN THE SOFTWARE.
(specialized-array-reshape array (make-interval '#(4)))) (specialized-array-reshape array (make-interval '#(4))))
(array->list array))) (array->list array)))
;; (test-error (test-error
;; (specialized-array-reshape (specialized-array-reshape
;; (array-reverse (array-reverse
;; (array-copy (make-array (make-interval '#(2 1 3 1)) list)) (array-copy (make-array (make-interval '#(2 1 3 1)) list))
;; '#(#t #f #f #f)) '#(#t #f #f #f))
;; (make-interval '#(6)))) (make-interval '#(6))))
;; (test-error (test-error
;; (specialized-array-reshape (specialized-array-reshape
;; (array-reverse (array-reverse
;; (array-copy (make-array (make-interval '#(2 1 3 1)) list)) (array-copy (make-array (make-interval '#(2 1 3 1)) list))
;; '#(#t #f #f #f)) '#(#t #f #f #f))
;; (make-interval '#(3 2)))) (make-interval '#(3 2))))
;; (test-error (test-error
;; (specialized-array-reshape (specialized-array-reshape
;; (array-reverse (array-reverse
;; (array-copy (make-array (make-interval '#(2 1 3 1)) list)) (array-copy (make-array (make-interval '#(2 1 3 1)) list))
;; '#(#f #f #t #f)) '#(#f #f #t #f))
;; (make-interval '#(6)))) (make-interval '#(6))))
;; (test-error (test-error
;; (specialized-array-reshape (specialized-array-reshape
;; (array-reverse (array-reverse
;; (array-copy (make-array (make-interval '#(2 1 3 1)) list)) (array-copy (make-array (make-interval '#(2 1 3 1)) list))
;; '#(#f #f #t #t)) '#(#f #f #t #t))
;; (make-interval '#(3 2)))) (make-interval '#(3 2))))
(test-error (test-error
(specialized-array-reshape (specialized-array-reshape