diff options
Diffstat (limited to 'libguile/vectors.c')
-rw-r--r-- | libguile/vectors.c | 362 |
1 files changed, 64 insertions, 298 deletions
diff --git a/libguile/vectors.c b/libguile/vectors.c index abcbfa0d1..1c659dee2 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -35,7 +35,6 @@ #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/dynwind.h" -#include "libguile/deprecation.h" #include "libguile/bdw-gc.h" @@ -47,43 +46,13 @@ int scm_is_vector (SCM obj) { - if (SCM_I_IS_NONWEAK_VECTOR (obj)) - return 1; - if (SCM_I_WVECTP (obj)) - { - scm_c_issue_deprecation_warning - ("Expecting vector? to be true for weak vectors is deprecated. " - "Use weak-vector? instead."); - return 1; - } - if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) - { - SCM v = SCM_I_ARRAY_V (obj); - if (SCM_I_IS_VECTOR (v)) - { - scm_c_issue_deprecation_warning - ("Expecting vector? to be true for rank-1 arrays is deprecated. " - "Use array?, array-rank, and array-type instead."); - return 1; - } - return 0; - } - return 0; + return SCM_I_IS_NONWEAK_VECTOR (obj); } int scm_is_simple_vector (SCM obj) { - if (SCM_I_IS_NONWEAK_VECTOR (obj)) - return 1; - if (SCM_I_WVECTP (obj)) - { - scm_c_issue_deprecation_warning - ("Expecting scm_is_simple_vector to be true for weak vectors is " - "deprecated. Use scm_is_weak_vector instead."); - return 1; - } - return 0; + return SCM_I_IS_NONWEAK_VECTOR (obj); } const SCM * @@ -91,9 +60,7 @@ scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { if (SCM_I_WVECTP (vec)) - /* FIXME: We should check each (weak) element of the vector for NULL and - convert it to SCM_BOOL_F. */ - abort (); + scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); scm_generalized_vector_get_handle (vec, h); if (lenp) @@ -110,9 +77,7 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { if (SCM_I_WVECTP (vec)) - /* FIXME: We should check each (weak) element of the vector for NULL and - convert it to SCM_BOOL_F. */ - abort (); + scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); scm_generalized_vector_get_handle (vec, h); if (lenp) @@ -134,48 +99,24 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, } #undef FUNC_NAME -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_DEFINE (scm_vector_length, "vector-length", 1, 0, 0, + (SCM v), + "Returns the number of elements in @var{vector} as an exact integer.") +#define FUNC_NAME s_scm_vector_length { - if (SCM_I_IS_VECTOR (v)) - { - if (SCM_I_WVECTP (v)) - scm_c_issue_deprecation_warning - ("Using vector-length on weak vectors is deprecated. " - "Use weak-vector-length from (ice-9 weak-vectors) instead."); - return scm_from_size_t (SCM_I_VECTOR_LENGTH (v)); - } - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - scm_c_issue_deprecation_warning - ("Using vector-length on arrays is deprecated. " - "Use array-length instead."); - return scm_from_size_t (dim->ubnd - dim->lbnd + 1); - } - else if (SCM_UNPACK (g_vector_length)) - { - scm_c_issue_deprecation_warning - ("Using vector-length as a primitive-generic is deprecated."); - return scm_call_generic_1 (g_vector_length, v); - } - else - { - scm_wrong_type_arg_msg ("vector-length", 1, v, "vector"); - return SCM_UNDEFINED; /* not reached */ - } + return scm_from_size_t (scm_c_vector_length (v)); } +#undef FUNC_NAME size_t scm_c_vector_length (SCM v) +#define FUNC_NAME s_scm_vector_length { - if (SCM_I_IS_NONWEAK_VECTOR (v)) - return SCM_I_VECTOR_LENGTH (v); - else - return scm_to_size_t (scm_vector_length (v)); + SCM_VALIDATE_VECTOR (1, v); + + return SCM_I_VECTOR_LENGTH (v); } +#undef FUNC_NAME SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); /* @@ -220,166 +161,68 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, } #undef FUNC_NAME -SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); - -/* - "@var{k} must be a valid index of @var{vector}.\n" - "@samp{Vector-ref} returns the contents of element @var{k} of\n" - "@var{vector}.\n\n" - "@lisp\n" - "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n" - "(vector-ref '#(1 1 2 3 5 8 13 21)\n" - " (let ((i (round (* 2 (acos -1)))))\n" - " (if (inexact? i)\n" - " (inexact->exact i)\n" - " i))) @result{} 13\n" - "@end lisp" -*/ - -SCM -scm_vector_ref (SCM v, SCM k) -#define FUNC_NAME s_vector_ref +SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0, + (SCM vector, SCM k), + "@var{k} must be a valid index of @var{vector}.\n" + "@samp{Vector-ref} returns the contents of element @var{k} of\n" + "@var{vector}.\n\n" + "@lisp\n" + "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n" + "(vector-ref '#(1 1 2 3 5 8 13 21)\n" + " (let ((i (round (* 2 (acos -1)))))\n" + " (if (inexact? i)\n" + " (inexact->exact i)\n" + " i))) @result{} 13\n" + "@end lisp") +#define FUNC_NAME s_scm_vector_ref { - return scm_c_vector_ref (v, scm_to_size_t (k)); + return scm_c_vector_ref (vector, scm_to_size_t (k)); } #undef FUNC_NAME SCM scm_c_vector_ref (SCM v, size_t k) +#define FUNC_NAME s_scm_vector_ref { - if (SCM_I_IS_NONWEAK_VECTOR (v)) - { - register SCM elt; + SCM_VALIDATE_VECTOR (1, v); - if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - elt = (SCM_I_VECTOR_ELTS(v))[k]; + if (k >= SCM_I_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); - return elt; - } - else if (SCM_I_WVECTP (v)) - { - scm_c_issue_deprecation_warning - ("Using vector-ref on weak vectors is deprecated. " - "Instead, use weak-vector-ref from (ice-9 weak-vectors)."); - return scm_c_weak_vector_ref (v, k); - } - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - SCM vv = SCM_I_ARRAY_V (v); - if (SCM_I_IS_VECTOR (vv)) - { - register SCM elt; - - scm_c_issue_deprecation_warning - ("Using vector-ref on arrays is deprecated. " - "Use array-ref instead."); - - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - elt = (SCM_I_VECTOR_ELTS (vv))[k]; - - if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv))) - { - scm_c_issue_deprecation_warning - ("Weak arrays are deprecated. Use weak vectors instead."); - /* ELT was a weak pointer and got nullified by the GC. */ - return SCM_BOOL_F; - } - - return elt; - } - scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); - } - else if (SCM_UNPACK (g_vector_ref)) - { - scm_c_issue_deprecation_warning - ("Using vector-ref as a primitive-generic is deprecated."); - return scm_call_generic_2 (g_vector_ref, v, scm_from_size_t (k)); - } - else - { - scm_wrong_type_arg_msg ("vector-ref", 1, v, "vector"); - return SCM_UNDEFINED; /* not reached */ - } + return SCM_SIMPLE_VECTOR_REF (v, k); } +#undef FUNC_NAME -SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); - -/* "@var{k} must be a valid index of @var{vector}.\n" - "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n" - "The value returned by @samp{vector-set!} is unspecified.\n" - "@lisp\n" - "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n" - " (vector-set! vec 1 '("Sue" "Sue"))\n" - " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n" - "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n" - "@end lisp" -*/ - -SCM -scm_vector_set_x (SCM v, SCM k, SCM obj) -#define FUNC_NAME s_vector_set_x +SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0, + (SCM vector, SCM k, SCM obj), + "@var{k} must be a valid index of @var{vector}.\n" + "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n" + "The value returned by @samp{vector-set!} is unspecified.\n" + "@lisp\n" + "(let ((vec (vector 0 '(2 2 2 2) \"Anna\")))\n" + " (vector-set! vec 1 '(\"Sue\" \"Sue\"))\n" + " vec) @result{} #(0 (\"Sue\" \"Sue\") \"Anna\")\n" + "(vector-set! '#(0 1 2) 1 \"doe\") @result{} @emph{error} ; constant vector\n" + "@end lisp") +#define FUNC_NAME s_scm_vector_set_x { - scm_c_vector_set_x (v, scm_to_size_t (k), obj); + scm_c_vector_set_x (vector, scm_to_size_t (k), obj); return SCM_UNSPECIFIED; } #undef FUNC_NAME void scm_c_vector_set_x (SCM v, size_t k, SCM obj) +#define FUNC_NAME s_scm_vector_set_x { - if (SCM_I_IS_NONWEAK_VECTOR (v)) - { - if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - (SCM_I_VECTOR_WELTS(v))[k] = obj; - } - else if (SCM_I_WVECTP (v)) - { - scm_c_issue_deprecation_warning - ("Using vector-set! on weak vectors is deprecated. " - "Instead, use weak-vector-set! from (ice-9 weak-vectors)."); - scm_c_weak_vector_set_x (v, k, obj); - } - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - SCM vv = SCM_I_ARRAY_V (v); - if (SCM_I_IS_VECTOR (vv)) - { - scm_c_issue_deprecation_warning - ("Using vector-set! on arrays is deprecated. " - "Use array-set! instead, but note the change in argument order."); - - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - (SCM_I_VECTOR_WELTS (vv))[k] = obj; - - if (SCM_I_WVECTP (vv)) - { - /* Make it a weak pointer. */ - SCM *link = & SCM_I_VECTOR_WELTS (vv)[k]; - SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj)); - scm_c_issue_deprecation_warning - ("Weak arrays are deprecated. Use weak vectors instead."); - } - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); - } - else if (SCM_UNPACK (g_vector_set_x)) - { - scm_c_issue_deprecation_warning - ("Using vector-set! as a primitive-generic is deprecated."); - scm_call_3 (g_vector_set_x, v, scm_from_size_t (k), obj); - } - else - scm_wrong_type_arg_msg ("vector-set!", 1, v, "vector"); + SCM_VALIDATE_VECTOR (1, v); + + if (k >= SCM_I_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); + + SCM_SIMPLE_VECTOR_SET (v, k, obj); } +#undef FUNC_NAME SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, (SCM k, SCM fill), @@ -403,28 +246,17 @@ SCM scm_c_make_vector (size_t k, SCM fill) #define FUNC_NAME s_scm_make_vector { - SCM *vector; - - vector = (SCM *) - scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM), - "vector"); + SCM vector; + unsigned long int j; - if (k > 0) - { - SCM *base; - unsigned long int j; + SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH); - SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH); - - base = vector + SCM_I_VECTOR_HEADER_SIZE; - for (j = 0; j != k; ++j) - base[j] = fill; - } + vector = scm_words ((k << 8) | scm_tc7_vector, k + 1); - ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector; - ((scm_t_bits *) vector)[1] = 0; + for (j = 0; j < k; ++j) + SCM_SIMPLE_VECTOR_SET (vector, j, fill); - return PTR2SCM (vector); + return vector; } #undef FUNC_NAME @@ -453,72 +285,6 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0, #undef FUNC_NAME -/* Weak vectors. */ - -/* Allocate memory for the elements of a weak vector on behalf of the - caller. */ -static SCM -make_weak_vector (scm_t_bits type, size_t c_size) -{ - SCM *vector; - size_t total_size; - - total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM); - vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector"); - - ((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect; - ((scm_t_bits *) vector)[1] = type; - - return PTR2SCM (vector); -} - -/* Return a new weak vector. The allocated vector will be of the given weak - vector subtype. It will contain SIZE elements which are initialized with - the FILL object, or, if FILL is undefined, with an unspecified object. */ -SCM -scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill) -{ - SCM wv, *base; - size_t c_size, j; - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH); - wv = make_weak_vector (type, c_size); - base = SCM_I_WVECT_GC_WVELTS (wv); - - for (j = 0; j != c_size; ++j) - base[j] = fill; - - return wv; -} - -/* Return a new weak vector with type TYPE and whose content are taken from - list LST. */ -SCM -scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst) -{ - SCM wv, *elt; - long c_size; - - c_size = scm_ilength (lst); - SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list"); - - wv = make_weak_vector(type, (size_t) c_size); - - for (elt = SCM_I_WVECT_GC_WVELTS (wv); - scm_is_pair (lst); - lst = SCM_CDR (lst), elt++) - { - *elt = SCM_CAR (lst); - } - - return wv; -} - - - SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), "Return a newly allocated list composed of the elements of @var{v}.\n" |