mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +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_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
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_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra;
}
if (SCM_I_ARRAYP (ra))
{
default:
vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
@ -540,8 +542,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
scm_i_ra_set_contp (res);
return res;
}
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME

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

@ -606,8 +606,21 @@
;;; 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
(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"
(let* ((a #(1 2 3))
(b (transpose-array a 0)))