From 418d5c8a8cffa4e9356fa21bc124ed3f3fafe320 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 27 May 2024 12:40:13 +0900 Subject: [PATCH] Build up empty arrays of higher dimensions for list/vector*->array Issue #962. --- lib/srfi/231/test.sld | 16 ++++++++++++++++ lib/srfi/231/transforms.scm | 20 +++++++++++++------- 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/lib/srfi/231/test.sld b/lib/srfi/231/test.sld index 8a537974..31c4fbb1 100644 --- a/lib/srfi/231/test.sld +++ b/lib/srfi/231/test.sld @@ -1821,10 +1821,26 @@ (array-every equal? (list*->array 0 '()) (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 (array-every equal? (vector*->array 0 '()) (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 list 1)) (test-error (array-any list diff --git a/lib/srfi/231/transforms.scm b/lib/srfi/231/transforms.scm index e5be17f5..06b2031c 100644 --- a/lib/srfi/231/transforms.scm +++ b/lib/srfi/231/transforms.scm @@ -524,7 +524,7 @@ (error "can't reshape" array new-domain))))) (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) ls)) @@ -532,7 +532,9 @@ (let lp ((ls nested-ls) (lens '()) (d dimension)) (cond ((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 (apply list->array (make-interval (list->vector (reverse lens))) @@ -572,16 +574,20 @@ (interval-lower-bound domain 0))))))) (define (flatten-vector->list vec d) - (if (and (positive? d) (vector? (vector-ref vec 0))) - (append-map (lambda (x) (flatten-vector->list x (- d 1))) - (vector->list vec)) - (vector->list vec))) + (cond + ((not (vector? vec)) '()) + ((and (positive? d) (vector? (vector-ref vec 0))) + (append-map (lambda (x) (flatten-vector->list x (- d 1))) + (vector->list vec))) + (else (vector->list vec)))) (define (vector*->array dimension nested-vec . o) (let lp ((vec nested-vec) (lens '()) (d dimension)) (cond ((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 (apply list->array (make-interval (reverse-list->vector lens))