diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-12-27 00:00:07 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-12-27 00:00:07 +0000 |
commit | de5c0f58016002cc0263716a11162a957bf31aeb (patch) | |
tree | 0a1c7d6b5d2bacf5074a70aeecac035ae6e397b7 /libguile/vectors.c | |
parent | de26705f9475179c7536bebeba8ddcc780c20097 (diff) | |
download | guile-de5c0f58016002cc0263716a11162a957bf31aeb.tar.gz |
(scm_c_vector_set_x): Make return type
void.
(scm_is_vector, scm_vector_p, scm_vector_length,
scm_c_vector_length, scm_vector_ref, scm_c_vector_ref,
scm_vector_set_x, scm_c_vector_set_x, scm_vector_to_list,
scm_vector_move_left_x, scm_vector_move_right_x,
scm_vector_fill_x): handle one-dimensional arrays.
Diffstat (limited to 'libguile/vectors.c')
-rw-r--r-- | libguile/vectors.c | 198 |
1 files changed, 117 insertions, 81 deletions
diff --git a/libguile/vectors.c b/libguile/vectors.c index b3eca7e7e..f5f8d4d11 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -27,36 +27,44 @@ #include "libguile/validate.h" #include "libguile/vectors.h" #include "libguile/unif.h" +#include "libguile/ramap.h" #include "libguile/srfi-4.h" #include "libguile/strings.h" #include "libguile/srfi-13.h" +int +scm_is_vector (SCM obj) +{ + return (SCM_VECTORP (obj) + || (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)); +} + SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a vector, otherwise return\n" "@code{#f}.") #define FUNC_NAME s_scm_vector_p { - return scm_from_bool (SCM_VECTORP (obj)); + return scm_from_bool (scm_is_vector (obj)); } #undef FUNC_NAME -int -scm_is_vector (SCM obj) -{ - return SCM_VECTORP (obj); -} - SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length); /* Returns the number of elements in @var{vector} as an exact integer. */ SCM scm_vector_length (SCM v) { - SCM_GASSERT1 (SCM_VECTORP(v), - g_vector_length, v, SCM_ARG1, s_vector_length); - return scm_from_size_t (SCM_VECTOR_LENGTH (v)); + if (SCM_VECTORP (v)) + return scm_from_size_t (SCM_VECTOR_LENGTH (v)); + else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) + { + scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); + return scm_from_size_t (dim->ubnd - dim->lbnd + 1); + } + else + SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL); } size_t @@ -65,12 +73,7 @@ scm_c_vector_length (SCM v) if (SCM_VECTORP (v)) return SCM_VECTOR_LENGTH (v); else - { - /* Call primitive generic to get an error or maybe dispatch to a - method. - */ - return scm_to_size_t (scm_vector_length (v)); - } + return scm_to_size_t (scm_vector_length (v)); } SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); @@ -136,29 +139,29 @@ SCM scm_vector_ref (SCM v, SCM k) #define FUNC_NAME s_vector_ref { - SCM_GASSERT2 (SCM_VECTORP (v), - g_vector_ref, v, k, SCM_ARG1, s_vector_ref); - SCM_GASSERT2 (SCM_I_INUMP (k), - g_vector_ref, v, k, SCM_ARG2, s_vector_ref); - SCM_ASSERT_RANGE (2, k, - SCM_I_INUM (k) < SCM_VECTOR_LENGTH (v) - && SCM_I_INUM (k) >= 0); - return SCM_VELTS (v)[(long) SCM_I_INUM (k)]; + return scm_c_vector_ref (v, scm_to_size_t (k)); } #undef FUNC_NAME SCM scm_c_vector_ref (SCM v, size_t k) { - if (SCM_VECTORP (v) && k < SCM_VECTOR_LENGTH (v)) - return SCM_VECTOR_REF (v, k); - else + if (SCM_VECTORP (v)) + { + if (k >= SCM_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); + return SCM_VECTOR_REF (v, k); + } + else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) { - /* Call primitive generic to get an error or maybe dispatch to a - method. - */ - return scm_vector_ref (v, scm_from_size_t (k)); + scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); + if (k >= dim->ubnd - dim->lbnd + 1) + scm_out_of_range (NULL, scm_from_size_t (k)); + k = SCM_ARRAY_BASE (v) + k*dim->inc; + return scm_c_generalized_vector_ref (SCM_ARRAY_V (v), k); } + else + SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL); } SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); @@ -178,34 +181,35 @@ SCM scm_vector_set_x (SCM v, SCM k, SCM obj) #define FUNC_NAME s_vector_set_x { - SCM_GASSERTn (SCM_VECTORP (v), - g_vector_set_x, scm_list_3 (v, k, obj), - SCM_ARG1, s_vector_set_x); - SCM_GASSERTn (SCM_I_INUMP (k), - g_vector_set_x, scm_list_3 (v, k, obj), - SCM_ARG2, s_vector_set_x); - SCM_ASSERT_RANGE (2, k, - SCM_I_INUM (k) < SCM_VECTOR_LENGTH (v) - && SCM_I_INUM (k) >= 0); - SCM_VECTOR_SET (v, (long) SCM_I_INUM(k), obj); + scm_c_vector_set_x (v, scm_to_size_t (k), obj); return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM +void scm_c_vector_set_x (SCM v, size_t k, SCM obj) { - if (SCM_VECTORP (v) && k < SCM_VECTOR_LENGTH (v)) + if (SCM_VECTORP (v)) { + if (k >= SCM_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); SCM_VECTOR_SET (v, k, obj); - return SCM_UNSPECIFIED; + } + else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) + { + scm_t_array_dim *dim = SCM_ARRAY_DIMS (v); + if (k >= dim->ubnd - dim->lbnd + 1) + scm_out_of_range (NULL, scm_from_size_t (k)); + k = SCM_ARRAY_BASE (v) + k*dim->inc; + scm_c_generalized_vector_set_x (SCM_ARRAY_V (v), k, obj); } else { - /* Call primitive generic to get an error or maybe dispatch to a - method. - */ - return scm_vector_set_x (v, scm_from_size_t (k), obj); + if (SCM_UNPACK (g_vector_set_x)) + scm_apply_generic (g_vector_set_x, + scm_list_3 (v, scm_from_size_t (k), obj)); + else + scm_wrong_type_arg_msg (NULL, 0, v, "vector"); } } @@ -265,13 +269,20 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_vector_to_list { - SCM res = SCM_EOL; - long i; - SCM const *data; - SCM_VALIDATE_VECTOR (1, v); - data = SCM_VELTS(v); - for(i = SCM_VECTOR_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); - return res; + if (SCM_VECTORP (v)) + { + SCM res = SCM_EOL; + long i; + SCM const *data; + data = SCM_VELTS(v); + for(i = SCM_VECTOR_LENGTH(v)-1; i >= 0; i--) + res = scm_cons(data[i], res); + return res; + } + else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) + return scm_array_to_list (v); + else + scm_wrong_type_arg_msg (NULL, 0, v, "vector"); } #undef FUNC_NAME @@ -282,12 +293,17 @@ SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0, "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_x { - register long i; - SCM_VALIDATE_VECTOR (1, v); - - for(i = SCM_VECTOR_LENGTH (v) - 1; i >= 0; i--) - SCM_VECTOR_SET(v, i, fill); - return SCM_UNSPECIFIED; + if (SCM_VECTORP (v)) + { + register long i; + for (i = SCM_VECTOR_LENGTH (v) - 1; i >= 0; i--) + SCM_VECTOR_SET (v, i, fill); + return SCM_UNSPECIFIED; + } + else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1) + return scm_array_fill_x (v, fill); + else + scm_wrong_type_arg_msg (NULL, 0, v, "vector"); } #undef FUNC_NAME @@ -314,19 +330,26 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, "@var{start1} is greater than @var{start2}.") #define FUNC_NAME s_scm_vector_move_left_x { + size_t len1, len2; size_t i, j, e; - - SCM_VALIDATE_VECTOR (1, vec1); - SCM_VALIDATE_VECTOR (4, vec2); - i = scm_to_unsigned_integer (start1, 0, SCM_VECTOR_LENGTH(vec1)); - e = scm_to_unsigned_integer (end1, i, SCM_VECTOR_LENGTH(vec1)); - j = scm_to_unsigned_integer (start2, 0, SCM_VECTOR_LENGTH(vec2)-(i-e)); - while (i<e) + len1 = scm_c_vector_length (vec1); + len2 = scm_c_vector_length (vec2); + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); + + /* Optimize common case of two regular vectors. + */ + if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2)) + { + for (; i < e; i++, j++) + SCM_VECTOR_SET (vec2, j, SCM_VECTOR_REF (vec1, i)); + } + else { - SCM_VECTOR_SET (vec2, j, SCM_VELTS (vec1)[i]); - i++; - j++; + for (; i < e; i++, j++) + scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, i)); } return SCM_UNSPECIFIED; @@ -344,20 +367,33 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, "@var{start1} is less than @var{start2}.") #define FUNC_NAME s_scm_vector_move_right_x { + size_t len1, len2; size_t i, j, e; - SCM_VALIDATE_VECTOR (1, vec1); - SCM_VALIDATE_VECTOR (4, vec2); - i = scm_to_unsigned_integer (start1, 0, SCM_VECTOR_LENGTH(vec1)); - e = scm_to_unsigned_integer (end1, i, SCM_VECTOR_LENGTH(vec1)); - j = scm_to_unsigned_integer (start2, 0, SCM_VECTOR_LENGTH(vec2)-(i-e)); - + len1 = scm_c_vector_length (vec1); + len2 = scm_c_vector_length (vec2); + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); + + /* Optimize common case of two regular vectors. + */ j += e - i; - while (i < e) + if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2)) + { + while (i < e) + { + e--, j--; + SCM_VECTOR_SET (vec2, j, SCM_VECTOR_REF (vec1, e)); + } + } + else { - j--; - e--; - SCM_VECTOR_SET (vec2, j, SCM_VELTS (vec1)[e]); + while (i < e) + { + e--, j--; + scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, e)); + } } return SCM_UNSPECIFIED; |