Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-04 03:36:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Build up empty arrays of higher dimensions for list/vector*->array

Browse source 
Issue #962.
This commit is contained in:
Alex Shinn 2024-05-27 12:40:13 +09:00
parent f9e3ed1639
commit 418d5c8a8c
2 changed files with 29 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1821,10 +1821,26 @@
(array-every equal? (array-every equal?
(list*->array 0 '()) (list*->array 0 '())
(make-array (make-interval '#()) (lambda () '())))) (make-array (make-interval '#()) (lambda () '()))))
(test-assert
(array-every equal?
(list*->array 1 '())
(make-array (make-interval '#(0)) (lambda () '()))))
(test-assert
(array-every equal?
(list*->array 2 '())
(make-array (make-interval '#(0 0)) (lambda () '()))))
(test-assert (test-assert
(array-every equal? (array-every equal?
(vector*->array 0 '()) (vector*->array 0 '())
(make-array (make-interval '#()) (lambda () '())))) (make-array (make-interval '#()) (lambda () '()))))
(test-assert
(array-every equal?
(vector*->array 1 '())
(make-array (make-interval '#(0)) (lambda () '()))))
(test-assert
(array-every equal?
(vector*->array 2 '())
(make-array (make-interval '#(0 0)) (lambda () '()))))
(test-error (array-any 1 2)) (test-error (array-any 1 2))
(test-error (array-any list 1)) (test-error (array-any list 1))
(test-error (array-any list (test-error (array-any list

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

@ -524,7 +524,7 @@
(error "can't reshape" array new-domain))))) (error "can't reshape" array new-domain)))))
(define (flatten ls d) (define (flatten ls d)
(if (and (positive? d) (pair? (car ls))) (if (and (positive? d) (pair? ls) (pair? (car ls)))
(append-map (lambda (x) (flatten x (- d 1))) ls) (append-map (lambda (x) (flatten x (- d 1))) ls)
ls)) ls))
@ -532,7 +532,9 @@
(let lp ((ls nested-ls) (lens '()) (d dimension)) (let lp ((ls nested-ls) (lens '()) (d dimension))
(cond (cond
((positive? d) ((positive? d)
(lp (car ls) (cons (length ls) lens) (- d 1))) (if (null? ls)
(lp '() (cons 0 lens) (- d 1))
(lp (car ls) (cons (length ls) lens) (- d 1))))
(else (else
(apply list->array (apply list->array
(make-interval (list->vector (reverse lens))) (make-interval (list->vector (reverse lens)))
@ -572,16 +574,20 @@
(interval-lower-bound domain 0))))))) (interval-lower-bound domain 0)))))))
(define (flatten-vector->list vec d) (define (flatten-vector->list vec d)
(if (and (positive? d) (vector? (vector-ref vec 0))) (cond
((not (vector? vec)) '())
((and (positive? d) (vector? (vector-ref vec 0)))
(append-map (lambda (x) (flatten-vector->list x (- d 1))) (append-map (lambda (x) (flatten-vector->list x (- d 1)))
(vector->list vec))
(vector->list vec))) (vector->list vec)))
(else (vector->list vec))))
(define (vector*->array dimension nested-vec . o) (define (vector*->array dimension nested-vec . o)
(let lp ((vec nested-vec) (lens '()) (d dimension)) (let lp ((vec nested-vec) (lens '()) (d dimension))
(cond (cond
((positive? d) ((positive? d)
(lp (vector-ref vec 0) (cons (vector-length vec) lens) (- d 1))) (if (vector? vec)
(lp (vector-ref vec 0) (cons (vector-length vec) lens) (- d 1))
(lp vec (cons 0 lens) (- d 1))))
(else (else
(apply list->array (apply list->array
(make-interval (reverse-list->vector lens)) (make-interval (reverse-list->vector lens))