X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/3394818c0a465c8b337252250174ecb0d13d726d..44e268898b522dd1c15e968d68adcb2f6fe12359:/libguile/vectors.c diff --git a/libguile/vectors.c b/libguile/vectors.c index eeb856995..75ba7cde0 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -37,6 +37,9 @@ #include "libguile/dynwind.h" #include "libguile/deprecation.h" +#include "libguile/boehm-gc.h" + + #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) @@ -64,6 +67,11 @@ const SCM * 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_generalized_vector_get_handle (vec, h); if (lenp) { @@ -78,6 +86,11 @@ SCM * 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_generalized_vector_get_handle (vec, h); if (lenp) { @@ -195,9 +208,17 @@ scm_c_vector_ref (SCM v, size_t k) { if (SCM_I_IS_VECTOR (v)) { + register SCM elt; + if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - return (SCM_I_VECTOR_ELTS(v))[k]; + scm_out_of_range (NULL, scm_from_size_t (k)); + elt = (SCM_I_VECTOR_ELTS(v))[k]; + + if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v)) + /* ELT was a weak pointer and got nullified by the GC. */ + return SCM_BOOL_F; + + return elt; } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -205,10 +226,18 @@ scm_c_vector_ref (SCM v, size_t k) SCM vv = SCM_I_ARRAY_V (v); if (SCM_I_IS_VECTOR (vv)) { + register SCM elt; + 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; - return (SCM_I_VECTOR_ELTS (vv))[k]; + elt = (SCM_I_VECTOR_ELTS (vv))[k]; + + if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv))) + /* 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"); } @@ -246,6 +275,12 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); (SCM_I_VECTOR_WELTS(v))[k] = obj; + if (SCM_I_WVECTP (v)) + { + /* Make it a weak pointer. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -257,6 +292,13 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) 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. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); @@ -345,43 +387,85 @@ scm_i_vector_free (SCM vec) "vector"); } -/* Allocate memory for a weak vector on behalf of the caller. 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_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill) + +/* Weak vectors. */ + + +/* Initialize RET as a weak vector of type TYPE of SIZE elements pointed to + by BASE. */ +#define MAKE_WEAK_VECTOR(_ret, _type, _size, _base) \ + (_ret) = scm_double_cell ((_size << 8) | scm_tc7_wvect, \ + (scm_t_bits) (_base), \ + (_type), \ + SCM_UNPACK (SCM_EOL)); + + +/* Allocate memory for the elements of a weak vector on behalf of the + caller. */ +static SCM * +allocate_weak_vector (scm_t_bits type, size_t c_size) { - size_t c_size; SCM *base; - SCM v; + + if (c_size > 0) + /* The base itself should not be scanned for pointers otherwise those + pointers will always be reachable. */ + base = scm_gc_malloc_pointerless (c_size * sizeof (SCM), "weak vector"); + else + base = NULL; + + return base; +} + +/* 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); + base = allocate_weak_vector (type, c_size); - if (c_size > 0) + for (j = 0; j != c_size; ++j) + base[j] = fill; + + MAKE_WEAK_VECTOR (wv, type, c_size, base); + + 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, *base, *elt; + long c_size; + + c_size = scm_ilength (lst); + SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list"); + + base = allocate_weak_vector (type, (size_t)c_size); + for (elt = base; + scm_is_pair (lst); + lst = SCM_CDR (lst), elt++) { - size_t j; - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector"); - for (j = 0; j != c_size; ++j) - base[j] = fill; + *elt = SCM_CAR (lst); } - else - base = NULL; - v = scm_double_cell ((c_size << 8) | scm_tc7_wvect, - (scm_t_bits) base, - type, - SCM_UNPACK (SCM_EOL)); - scm_remember_upto_here_1 (fill); + MAKE_WEAK_VECTOR (wv, type, (size_t)c_size, base); - return v; + 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"