mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Don't use scm_is_generalized_vector in transpose-array

Browse source 
* libguile/arrays.c (scm_transpose_array)
  - Use scm_c_array_rank(), which contains an implicit is_array test.
  - Handle the rank 0 case.
* test-suite/tests/arrays.test
  - Add test for rank 0 case.
  - Add failure test for non array argument.
This commit is contained in:
Daniel Llorens 2013-04-10 15:11:33 +02:00 • committed by Andy Wingo
parent 82c481dd11
commit b8ff37f5ea
2 changed files with 21 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/arrays.c
View file

@ -477,8 +477,13 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
SCM_VALIDATE_REST_ARGUMENT (args); SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
if (scm_is_generalized_vector (ra)) switch (scm_c_array_rank (ra))
{ {
case 0:
if (!scm_is_null (args))
SCM_WRONG_NUM_ARGS ();
return ra;
case 1:
/* Make sure that we are called with a single zero as /* Make sure that we are called with a single zero as
arguments. arguments.
*/ */
@ -487,10 +492,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra; return ra;
} default:
if (SCM_I_ARRAYP (ra))
{
vargs = scm_vector (args); vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS (); SCM_WRONG_NUM_ARGS ();
@ -540,8 +542,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
scm_i_ra_set_contp (res); scm_i_ra_set_contp (res);
return res; return res;
} }
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
} }
#undef FUNC_NAME #undef FUNC_NAME

13
test-suite/tests/arrays.test
View file

@ -606,8 +606,21 @@
;;; transpose-array ;;; transpose-array
;;; ;;;
; see strings.test.
(define exception:wrong-type-arg
(cons #t "Wrong type"))
(with-test-prefix "transpose-array" (with-test-prefix "transpose-array"
(pass-if-exception "non array argument" exception:wrong-type-arg
(transpose-array 99))
(pass-if "rank 0"
(let* ((a #0(99))
(b (transpose-array a)))
(and (array-equal? a b)
(eq? (shared-array-root a) (shared-array-root b)))))
(pass-if "rank 1" (pass-if "rank 1"
(let* ((a #(1 2 3)) (let* ((a #(1 2 3))
(b (transpose-array a 0))) (b (transpose-array a 0)))