diff --git a/libguile/arrays.c b/libguile/arrays.c index 52fe90a19..05f85978a 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -71,10 +71,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, { if (SCM_I_ARRAYP (ra)) return SCM_I_ARRAY_V (ra); - else if (!scm_is_array (ra)) - scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); - else + else if (scm_is_array (ra)) return ra; + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME @@ -84,13 +84,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, "Return the root vector index of the first element in the array.") #define FUNC_NAME s_scm_shared_array_offset { - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (ra, &handle); - res = scm_from_size_t (handle.base); - scm_array_handle_release (&handle); - return res; + if (SCM_I_ARRAYP (ra)) + return scm_from_size_t (SCM_I_ARRAY_BASE (ra)); + else if (scm_is_array (ra)) + return scm_from_size_t (0); + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME @@ -100,18 +99,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, "For each dimension, return the distance between elements in the root vector.") #define FUNC_NAME s_scm_shared_array_increments { - scm_t_array_handle handle; - SCM res = SCM_EOL; - size_t k; - scm_t_array_dim *s; - - scm_array_get_handle (ra, &handle); - k = scm_array_handle_rank (&handle); - s = scm_array_handle_dims (&handle); - while (k--) - res = scm_cons (scm_from_ssize_t (s[k].inc), res); - scm_array_handle_release (&handle); - return res; + if (SCM_I_ARRAYP (ra)) + { + size_t k = SCM_I_ARRAY_NDIM (ra); + SCM res = SCM_EOL; + scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra); + while (k--) + res = scm_cons (scm_from_ssize_t (dims[k].inc), res); + return res; + } + else if (scm_is_array (ra)) + return scm_list_1 (scm_from_ssize_t (1)); + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index e76c699e9..7c7b46704 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -23,9 +23,13 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-4 gnu)) -;;; -;;; array? -;;; +(define (array-row a i) + (make-shared-array a (lambda (j) (list i j)) + (cadr (array-dimensions a)))) + +(define (array-col a j) + (make-shared-array a (lambda (i) (list i j)) + (car (array-dimensions a)))) (define exception:wrong-num-indices (cons 'misc-error "^wrong number of indices.*")) @@ -33,6 +37,15 @@ (define exception:length-non-negative (cons 'read-error ".*array length must be non-negative.*")) +(define exception:wrong-type-arg + (cons #t "Wrong type")) + +(define exception:mapping-out-of-range + (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array + +;;; +;;; array? +;;; (with-test-prefix "array?" @@ -210,9 +223,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/c&e "make-shared-array" ;; this failed in guile 1.8.0 @@ -391,14 +401,58 @@ (b (make-shared-array a amap2 2 2))) (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))) +;;; +;;; shared-array-offset +;;; + +(with-test-prefix/c&e "shared-array-offset" + + (pass-if "plain vector" + (zero? (shared-array-offset (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (zero? (shared-array-offset (make-array 0 4 4)))) + + (pass-if "row of rank-2 array, I" + (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0)))) + + (pass-if "row of rank-2 array, II" + (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1)))) + + (pass-if "col of rank-2 array, I" + (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array, II" + (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1))))) + + +;;; +;;; shared-array-increments +;;; + +(with-test-prefix/c&e "shared-array-increments" + + (pass-if "plain vector" + (equal? '(1) (shared-array-increments (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (equal? '(4 1) (shared-array-increments (make-array 0 3 4)))) + + (pass-if "plain array rank 3" + (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5)))) + + (pass-if "row of rank-2 array" + (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array" + (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0))))) + + ;;; ;;; transpose-array ;;; ; see strings.test. -(define exception:wrong-type-arg - (cons #t "Wrong type")) - (with-test-prefix/c&e "transpose-array" (pass-if-exception "non array argument" exception:wrong-type-arg @@ -809,10 +863,6 @@ ;;; slices as generalized vectors ;;; -(define (array-row a i) - (make-shared-array a (lambda (j) (list i j)) - (cadr (array-dimensions a)))) - (with-test-prefix/c&e "generalized vector slices" (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1) #u32(2 3)))