diff --git a/libguile/uniform.c b/libguile/uniform.c index 6df7806fd..0be344d94 100644 --- a/libguile/uniform.c +++ b/libguile/uniform.c @@ -87,11 +87,10 @@ scm_is_uniform_vector (SCM obj) scm_t_array_handle h; int ret = 0; - if (scm_is_array (obj)) + if (scm_is_array (obj) && !SCM_I_ARRAYP (obj)) { scm_array_get_handle (obj, &h); - ret = 1 == scm_array_handle_rank (&h) - && SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type); + ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type); scm_array_handle_release (&h); } return ret; @@ -107,7 +106,7 @@ scm_c_uniform_vector_length (SCM uvec) "uniform vector"); scm_array_get_handle (uvec, &h); - ret = h.dims[0].ubnd - h.dims[0].lbnd + 1; + ret = h.dims[0].ubnd + 1; scm_array_handle_release (&h); return ret; } @@ -184,7 +183,6 @@ scm_c_uniform_vector_ref (SCM v, size_t pos) scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); scm_array_get_handle (v, &h); - pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc; ret = h.impl->vref (&h, pos); scm_array_handle_release (&h); return ret; @@ -210,7 +208,6 @@ scm_c_uniform_vector_set_x (SCM v, size_t pos, SCM val) scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector"); scm_array_get_handle (v, &h); - pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc; h.impl->vset (&h, pos, val); scm_array_handle_release (&h); } @@ -251,6 +248,8 @@ scm_uniform_vector_writable_elements (SCM uvec, size_t *lenp, ssize_t *incp) { void *ret; + if (!scm_is_uniform_vector (uvec)) + scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector"); scm_array_get_handle (uvec, h); /* FIXME nonlocal exit */ ret = scm_array_handle_uniform_writable_elements (h); diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 0da1a1992..8ad97f4b2 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -22,16 +22,22 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-4 gnu)) -;;; -;;; array? -;;; - (define exception:wrong-num-indices (cons 'misc-error "^wrong number of indices.*")) (define exception:length-non-negative (cons 'read-error ".*array length must be non-negative.*")) +(define exception:mapping-out-of-range + (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array + +; see strings.test. +(define exception:wrong-type-arg + (cons #t "Wrong type")) + +;;; +;;; array? +;;; (with-test-prefix "sanity" ;; At the current time of writing, bignums have a tc7 that is one bit @@ -210,9 +216,6 @@ ;;; make-shared-array ;;; -(define exception:mapping-out-of-range - (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array - (with-test-prefix "make-shared-array" ;; this failed in guile 1.8.0 @@ -313,10 +316,6 @@ ;;; transpose-array ;;; -; see strings.test. -(define exception:wrong-type-arg - (cons #t "Wrong type")) - (with-test-prefix "transpose-array" (pass-if-exception "non array argument" exception:wrong-type-arg @@ -670,21 +669,36 @@ (array-set! a -128 0) (= -128 (uniform-vector-ref a 0)))))) - (with-test-prefix "shared with rank 1 remain uniform vectors" + (with-test-prefix "arrays with lbnd!=0 are not uniform vectors" + + (pass-if "bit" + (and (not (uniform-vector? #1b@1(#t #t #t))) + (uniform-vector? #1b(#t #t #t)))) + + (pass-if "s8" + (and (not (uniform-vector? #1s8@1(0 1 2))) + (uniform-vector? #1s8(0 1 2))))) + + + (with-test-prefix "shared with rank 1 do not remain uniform vectors" (let ((a #f64(1 2 3 4))) - (pass-if "change offset" + (pass-if-exception "change offset -length" exception:wrong-type-arg (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3))) - (and (uniform-vector? b) - (= 3 (uniform-vector-length b)) - (array-equal? b #f64(2 3 4))))) + (= 3 (uniform-vector-length b)))) - (pass-if "change stride" - (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2))) - (and (uniform-vector? c) - (= 2 (uniform-vector-length c)) - (array-equal? c #f64(1 3)))))))) + (pass-if-exception "change offset -ref" exception:wrong-type-arg + (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3))) + (= 2 (uniform-vector-ref b 0)))) + + (pass-if-exception "change stride -length" exception:wrong-type-arg + (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2))) + (= 3 (uniform-vector-length b)))) + + (pass-if-exception "change stride -ref" exception:wrong-type-arg + (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2))) + (= 2 (uniform-vector-ref b 0))))))) ;;; ;;; syntax