mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

* weaks.c: Use new vector elements API or simple vector

Browse source 
API, as appropriate.

* srfi-4.h, srfi-4.c, srfi-4.i.c (scm_array_handle_uniform_elements,
scm_array_handle_uniform_writable_elements,
scm_uniform_vector_elements, scm_uniform_vector_writable_elements):
(scm_<foo>vector_elements, scm_<foo>vector_writable_elements): Use
scm_t_array_handle, deliver length and increment.
(scm_array_handle_<foo>_elements,
scm_array_handle_<foo>_writable_elements): New.

* unif.h, unif.c (scm_t_array_handle, scm_array_get_handle,
scm_array_handle_rank, scm_array_handle_dims, scm_array_handle_ref
scm_array_handle_set, scm_array_handle_elements
scm_array_handle_writable_elements, scm_vector_get_handle): New.
(scm_make_uve, scm_array_prototype, scm_list_to_uniform_array,
scm_dimensions_to_uniform_array): Deprecated for real.  (scm_array_p,
scm_i_array_p): Use latter for SCM_DEFINE since snarfing wont allow a
mismatch between C and Scheme arglists.  (scm_make_shared_array,
scm_enclose_array): Correctly use scm_c_generalized_vector_length
instead of scm_uniform_vector_length.

* weaks.h, weaks.c: Use new internal weak vector API from
vectors.h.

* Makefile.am (libguile_la_SOURCES, DOT_X_FILES, DOT_DOC_FILES,
EXTRA_libguile_la_SOURCES): Changed ramap.c and unif.c from being
'extra' to being regular sources.
(noinst_HEADERS): Added quicksort.i.c.
* quicksort.i.c: New file.

* vectors.h, vector.c (SCM_VECTORP, SCM_VECTOR_LENGTH, SCM_VELTS,
SCM_WRITABLE_VELTS, SCM_VECTOR_REF, SCM_VECTOR_SET): Deprecated and
reimplemented.  Replaced all uses with scm_vector_elements,
scm_vector_writable_elements, or SCM_SIMPLE_VECTOR_*, as appropriate.
(scm_is_simple_vector, SCM_SIMPLE_VECTOR_LENGTH,
SCM_SIMPLE_VECTOR_REF, SCM_SIMPLE_VECTOR_SET, SCM_SIMPLE_VECTOR_LOC):
New.  (SCM_VECTOR_BASE, SCM_SET_VECTOR_BASE, SCM_VECTOR_MAX_LENGTH,
SCM_MAKE_VECTOR_TAG, SCM_SET_VECTOR_LENGTH, SCM_VELTS_AS_STACKITEMS,
SCM_SETVELTS, SCM_GC_WRITABLE_VELTS): Removed.  (scm_vector_copy):
New.  (scm_vector_elements, scm_vector_writable_elements): Use
scm_t_array_handle, deliver length and increment.  Moved to
unif.h. Changed all uses.  (scm_vector_release_elements,
scm_vector_release_writable_elements,
(scm_frame_vector_release_elements,
scm_frame_vector_release_writable_elements): Removed.
(SCM_I_IS_VECTOR, SCM_I_VECTOR_ELTS, SCM_I_VECTOR_WELTS,
SCM_I_VECTOR_LENGTH, scm_i_vector_free): New internal API.
(SCM_I_WVECTP SCM_I_WVECT_LENGTH SCM_I_WVECT_VELTS
SCM_I_WVECT_GC_WVELTS SCM_I_WVECT_TYPE SCM_I_WVECT_GC_CHAIN
SCM_I_SET_WVECT_GC_CHAIN, scm_i_allocate_weak_vector): New, for weak
vectors.
This commit is contained in:
Marius Vollmer 2005-01-02 20:06:08 +00:00
parent 9c6e33c62a
commit 6e708ef2b1
9 changed files with 714 additions and 410 deletions
Download patch file Download diff file Expand all files Collapse all files

146
libguile/srfi-4.c
View file

@ -584,67 +584,6 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
}
#undef FUNC_NAME
const void *
scm_uniform_vector_elements (SCM uvec)
{
if (scm_is_uniform_vector (uvec))
return SCM_UVEC_BASE (uvec);
else
scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}
void
scm_uniform_vector_release_elements (SCM uvec)
{
/* Nothing to do right now, but this function might come in handy
when uniform vectors need to be locked when giving away a pointer
to their elements.
Also, a call to scm_uniform_vector_release acts like
scm_remember_upto_here, which is needed in any case.
*/
scm_remember_upto_here_1 (uvec);
}
void
scm_frame_uniform_vector_release_elements (SCM uvec)
{
scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec,
SCM_F_WIND_EXPLICITLY);
}
void *
scm_uniform_vector_writable_elements (SCM uvec)
{
if (scm_is_uniform_vector (uvec))
return SCM_UVEC_BASE (uvec);
else
scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}
void
scm_uniform_vector_release_writable_elements (SCM uvec)
{
/* Nothing to do right now, but this function might come in handy
when uniform vectors need to be locked when giving away a pointer
to their elements.
Also, a call to scm_uniform_vector_release acts like
scm_remember_upto_here, which is needed in any case.
*/
scm_remember_upto_here_1 (uvec);
}
void
scm_frame_uniform_vector_release_writable_elements (SCM uvec)
{
scm_frame_unwind_handler_with_scm
(scm_uniform_vector_release_writable_elements, uvec,
SCM_F_WIND_EXPLICITLY);
}
size_t
scm_uniform_vector_element_size (SCM uvec)
{
@ -665,6 +604,50 @@ scm_uniform_element_size (SCM obj)
return 0;
}
const void *
scm_array_handle_uniform_elements (scm_t_array_handle *h)
{
return scm_array_handle_uniform_writable_elements (h);
}
void *
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
SCM vec = h->array;
if (SCM_ARRAYP (vec))
vec = SCM_ARRAY_V (vec);
if (scm_is_uniform_vector (vec))
{
size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
char *elts = SCM_UVEC_BASE (vec);
return (void *) (elts + size*h->base);
}
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
const void *
scm_uniform_vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
}
void *
scm_uniform_vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
scm_vector_get_handle (uvec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_uniform_writable_elements (h);
}
SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
(SCM v),
"Return the number of elements in the uniform vector @var{v}.")
@ -689,12 +672,15 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
"An error is signalled when the last element has only\n"
"been partially filled before reaching end-of-file or in\n"
"the single call to read(2).\n\n"
"@code{uniform-array-read!} returns the number of elements read.\n"
"@code{uniform-vector-read!} returns the number of elements\n"
"read.\n\n"
"@var{port-or-fdes} may be omitted, in which case it defaults\n"
"to the value returned by @code{(current-input-port)}.")
#define FUNC_NAME s_scm_uniform_vector_read_x
{
scm_t_array_handle handle;
size_t vlen, sz, ans;
ssize_t inc;
size_t cstart, cend;
size_t remaining, off;
void *base;
@ -706,13 +692,18 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
|| (SCM_OPINPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME);
scm_frame_begin (0);
if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
vlen = scm_c_uniform_vector_length (uvec);
base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
sz = scm_uniform_vector_element_size (uvec);
base = scm_uniform_vector_writable_elements (uvec);
scm_frame_uniform_vector_release_writable_elements (uvec);
if (inc != 1)
{
/* XXX - we should of course support non contiguous vectors. */
scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
scm_list_1 (uvec));
}
cstart = 0;
cend = vlen;
@ -740,7 +731,7 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
{
size_t to_copy = min (pt->read_end - pt->read_pos,
remaining);
memcpy (base + off, pt->read_pos, to_copy);
pt->read_pos += to_copy;
remaining -= to_copy;
@ -774,8 +765,6 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
ans = n / sz;
}
scm_frame_end ();
return scm_from_size_t (ans);
}
#undef FUNC_NAME
@ -800,7 +789,9 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
"@code{(current-output-port)}.")
#define FUNC_NAME s_scm_uniform_vector_write
{
scm_t_array_handle handle;
size_t vlen, sz, ans;
ssize_t inc;
size_t cstart, cend;
size_t amount, off;
const void *base;
@ -814,12 +805,15 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
|| (SCM_OPOUTPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME);
scm_frame_begin (0);
vlen = scm_c_generalized_vector_length (uvec);
base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
sz = scm_uniform_vector_element_size (uvec);
base = scm_uniform_vector_elements (uvec);
scm_frame_uniform_vector_release_elements (uvec);
if (inc != 1)
{
/* XXX - we should of course support non contiguous vectors. */
scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
scm_list_1 (uvec));
}
cstart = 0;
cend = vlen;
@ -849,8 +843,6 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
ans = n / sz;
}
scm_frame_end ();
return scm_from_size_t (ans);
}
#undef FUNC_NAME

154
libguile/srfi-4.h
View file

@ -21,6 +21,7 @@
#include "libguile/__scm.h"
#include "libguile/unif.h"
/* Generic procedures.
*/
@ -40,14 +41,16 @@ SCM_API size_t scm_c_uniform_vector_length (SCM v);
SCM_API size_t scm_c_uniform_vector_size (SCM v);
SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
SCM_API size_t scm_uniform_vector_element_size (SCM uvec);
SCM_API const void *scm_uniform_vector_elements (SCM uvec);
SCM_API void scm_uniform_vector_release_elements (SCM uvec);
SCM_API void scm_frame_uniform_vector_release_elements (SCM uvec);
SCM_API void *scm_uniform_vector_writable_elements (SCM uvec);
SCM_API void scm_uniform_vector_release_writable_elements (SCM uvec);
SCM_API void scm_frame_uniform_vector_release_writable_elements (SCM uvec);
SCM_API size_t scm_uniform_vector_element_size (SCM v);
SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);
SCM_API const void *scm_uniform_vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
/* Specific procedures.
*/
@ -62,8 +65,15 @@ SCM_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u8vector (SCM l);
SCM_API SCM scm_any_to_u8vector (SCM obj);
SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec);
SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec);
SCM_API const scm_t_uint8 *scm_array_handle_u8_elements (scm_t_array_handle *h);
SCM_API scm_t_uint8 *scm_array_handle_u8_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_s8vector_p (SCM obj);
SCM_API SCM scm_make_s8vector (SCM n, SCM fill);
@ -75,8 +85,15 @@ SCM_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s8vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s8vector (SCM l);
SCM_API SCM scm_any_to_s8vector (SCM obj);
SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec);
SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec);
SCM_API const scm_t_int8 *scm_array_handle_s8_elements (scm_t_array_handle *h);
SCM_API scm_t_int8 *scm_array_handle_s8_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_u16vector_p (SCM obj);
SCM_API SCM scm_make_u16vector (SCM n, SCM fill);
@ -88,8 +105,16 @@ SCM_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u16vector (SCM l);
SCM_API SCM scm_any_to_u16vector (SCM obj);
SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec);
SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec);
SCM_API const scm_t_uint16 *scm_array_handle_u16_elements (scm_t_array_handle *h);
SCM_API scm_t_uint16 *scm_array_handle_u16_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_s16vector_p (SCM obj);
SCM_API SCM scm_make_s16vector (SCM n, SCM fill);
@ -101,8 +126,15 @@ SCM_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s16vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s16vector (SCM l);
SCM_API SCM scm_any_to_s16vector (SCM obj);
SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec);
SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec);
SCM_API const scm_t_int16 *scm_array_handle_s16_elements (scm_t_array_handle *h);
SCM_API scm_t_int16 *scm_array_handle_s16_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_u32vector_p (SCM obj);
SCM_API SCM scm_make_u32vector (SCM n, SCM fill);
@ -114,8 +146,16 @@ SCM_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u32vector (SCM l);
SCM_API SCM scm_any_to_u32vector (SCM obj);
SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec);
SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec);
SCM_API const scm_t_uint32 *scm_array_handle_u32_elements (scm_t_array_handle *h);
SCM_API scm_t_uint32 *scm_array_handle_u32_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_s32vector_p (SCM obj);
SCM_API SCM scm_make_s32vector (SCM n, SCM fill);
@ -127,8 +167,15 @@ SCM_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s32vector (SCM l);
SCM_API SCM scm_any_to_s32vector (SCM obj);
SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec);
SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec);
SCM_API const scm_t_int32 *scm_array_handle_s32_elements (scm_t_array_handle *h);
SCM_API scm_t_int32 *scm_array_handle_s32_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_u64vector_p (SCM obj);
SCM_API SCM scm_make_u64vector (SCM n, SCM fill);
@ -140,8 +187,16 @@ SCM_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_u64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_u64vector (SCM l);
SCM_API SCM scm_any_to_u64vector (SCM obj);
SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec);
SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec);
SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h);
SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_s64vector_p (SCM obj);
SCM_API SCM scm_make_s64vector (SCM n, SCM fill);
@ -153,8 +208,15 @@ SCM_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_s64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_s64vector (SCM l);
SCM_API SCM scm_any_to_s64vector (SCM obj);
SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec);
SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec);
SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h);
SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h);
SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_f32vector_p (SCM obj);
SCM_API SCM scm_make_f32vector (SCM n, SCM fill);
@ -166,8 +228,15 @@ SCM_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f32vector (SCM l);
SCM_API SCM scm_any_to_f32vector (SCM obj);
SCM_API const float *scm_f32vector_elements (SCM uvec);
SCM_API float *scm_f32vector_writable_elements (SCM uvec);
SCM_API const float *scm_array_handle_f32_elements (scm_t_array_handle *h);
SCM_API float *scm_array_handle_f32_writable_elements (scm_t_array_handle *h);
SCM_API const float *scm_f32vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API float *scm_f32vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_f64vector_p (SCM obj);
SCM_API SCM scm_make_f64vector (SCM n, SCM fill);
@ -179,8 +248,15 @@ SCM_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_f64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_f64vector (SCM l);
SCM_API SCM scm_any_to_f64vector (SCM obj);
SCM_API const double *scm_f64vector_elements (SCM uvec);
SCM_API double *scm_f64vector_writable_elements (SCM uvec);
SCM_API const double *scm_array_handle_f64_elements (scm_t_array_handle *h);
SCM_API double *scm_array_handle_f64_writable_elements (scm_t_array_handle *h);
SCM_API const double *scm_f64vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API double *scm_f64vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_c32vector_p (SCM obj);
SCM_API SCM scm_make_c32vector (SCM n, SCM fill);
@ -192,8 +268,15 @@ SCM_API SCM scm_c32vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_c32vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_c32vector (SCM l);
SCM_API SCM scm_any_to_c32vector (SCM obj);
SCM_API const float *scm_c32vector_elements (SCM uvec);
SCM_API float *scm_c32vector_writable_elements (SCM uvec);
SCM_API const float *scm_array_handle_c32_elements (scm_t_array_handle *h);
SCM_API float *scm_array_handle_c32_writable_elements (scm_t_array_handle *h);
SCM_API const float *scm_c32vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API float *scm_c32vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_c64vector_p (SCM obj);
SCM_API SCM scm_make_c64vector (SCM n, SCM fill);
@ -205,8 +288,15 @@ SCM_API SCM scm_c64vector_set_x (SCM uvec, SCM index, SCM value);
SCM_API SCM scm_c64vector_to_list (SCM uvec);
SCM_API SCM scm_list_to_c64vector (SCM l);
SCM_API SCM scm_any_to_c64vector (SCM obj);
SCM_API const double *scm_c64vector_elements (SCM uvec);
SCM_API double *scm_c64vector_writable_elements (SCM uvec);
SCM_API const double *scm_array_handle_c64_elements (scm_t_array_handle *h);
SCM_API double *scm_array_handle_c64_writable_elements (scm_t_array_handle *h);
SCM_API const double *scm_c64vector_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API double *scm_c64vector_writable_elements (SCM uvec,
scm_t_array_handle *h,
size_t *lenp,
ssize_t *incp);
SCM_API SCM scm_i_generalized_vector_type (SCM vec);
SCM_API const char *scm_i_uniform_vector_tag (SCM uvec);

58
libguile/srfi-4.i.c
View file

@ -1,4 +1,4 @@
/* This file defines the procedures related to one type of homogenous
/* This file defines the procedures related to one type of uniform
numeric vector. It is included multiple time in srfi-4.c, once for
each type.
@ -45,7 +45,7 @@ SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
(SCM len, SCM fill),
"Return a newly allocated homogeneous numeric vector which can\n"
"Return a newly allocated uniform numeric vector which can\n"
"hold @var{len} elements. If @var{fill} is given, it is used to\n"
"initialize the elements, otherwise the contents of the vector\n"
"is unspecified.")
@ -65,7 +65,7 @@ F(scm_take_,TAG,vector) (const CTYPE *data, size_t n)
SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
(SCM l),
"Return a newly allocated homogeneous numeric vector containing\n"
"Return a newly allocated uniform numeric vector containing\n"
"all argument values.")
#define FUNC_NAME s_F(scm_,TAG,vector)
{
@ -76,7 +76,7 @@ SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
(SCM uvec),
"Return the number of elements in the homogeneous numeric vector\n"
"Return the number of elements in the uniform numeric vector\n"
"@var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_length)
{
@ -87,7 +87,7 @@ SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
(SCM uvec, SCM index),
"Return the element at @var{index} in the homogeneous numeric\n"
"Return the element at @var{index} in the uniform numeric\n"
"vector @var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_ref)
{
@ -98,7 +98,7 @@ SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
(SCM uvec, SCM index, SCM value),
"Set the element at @var{index} in the homogeneous numeric\n"
"Set the element at @var{index} in the uniform numeric\n"
"vector @var{uvec} to @var{value}. The return value is not\n"
"specified.")
#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
@ -110,7 +110,7 @@ SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
(SCM uvec),
"Convert the homogeneous numeric vector @var{uvec} to a list.")
"Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
{
return uvec_to_list (TYPE, uvec);
@ -120,7 +120,7 @@ SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
(SCM l),
"Convert the list @var{l} to a numeric homogeneous vector.")
"Convert the list @var{l} to a numeric uniform vector.")
#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
{
return list_to_uvec (TYPE, l);
@ -130,7 +130,7 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
(SCM obj),
"Convert @var{obj}, which can be a list, vector, or\n"
"homogenous vector, to a numeric homogenous vector of\n"
"uniform vector, to a numeric uniform vector of\n"
"type " S(TAG)".")
#define FUNC_NAME s_F(scm_any_to_,TAG,vector)
{
@ -139,17 +139,45 @@ SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
#undef FUNC_NAME
const CTYPE *
F(scm_,TAG,vector_elements) (SCM obj)
F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
{
uvec_assert (TYPE, obj);
return (const CTYPE *)SCM_UVEC_BASE (obj);
return F(scm_array_handle_,TAG,_writable_elements) (h);
}
CTYPE *
F(scm_,TAG,vector_writable_elements) (SCM obj)
F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
{
uvec_assert (TYPE, obj);
return (CTYPE *)SCM_UVEC_BASE (obj);
SCM vec = h->array;
if (SCM_ARRAYP (vec))
vec = SCM_ARRAY_V (vec);
uvec_assert (TYPE, vec);
if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
else
return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
}
const CTYPE *
F(scm_,TAG,vector_elements) (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
}
CTYPE *
F(scm_,TAG,vector_writable_elements) (SCM uvec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
scm_vector_get_handle (uvec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return F(scm_array_handle_,TAG,_writable_elements) (h);
}
#undef paste

176
libguile/unif.c
View file

@ -253,6 +253,122 @@ scm_is_typed_array (SCM obj, SCM type)
return scm_is_eq (type, scm_i_generalized_vector_type (obj));
}
void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
h->array = array;
if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array))
{
h->dims = SCM_ARRAY_DIMS (array);
h->base = SCM_ARRAY_BASE (array);
}
else if (scm_is_generalized_vector (array))
{
h->dim0.lbnd = 0;
h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
h->dim0.inc = 1;
h->dims = &h->dim0;
h->base = 0;
}
else
scm_wrong_type_arg_msg (NULL, 0, array, "array");
}
size_t
scm_array_handle_rank (scm_t_array_handle *h)
{
if (SCM_ARRAYP (h->array) || SCM_ENCLOSED_ARRAYP (h->array))
return SCM_ARRAY_NDIM (h->array);
else
return 1;
}
scm_t_array_dim *
scm_array_handle_dims (scm_t_array_handle *h)
{
return h->dims;
}
SCM
scm_array_handle_ref (scm_t_array_handle *h, size_t pos)
{
pos += h->base;
if (SCM_ARRAYP (h->array))
return scm_i_cvref (SCM_ARRAY_V (h->array), pos, 0);
if (SCM_ENCLOSED_ARRAYP (h->array))
return scm_i_cvref (SCM_ARRAY_V (h->array), pos, 1);
return scm_c_generalized_vector_ref (h->array, pos);
}
void
scm_array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
{
pos += h->base;
if (SCM_ARRAYP (h->array))
scm_c_generalized_vector_set_x (SCM_ARRAY_V (h->array), pos, val);
if (SCM_ENCLOSED_ARRAYP (h->array))
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
scm_c_generalized_vector_set_x (h->array, pos, val);
}
const SCM *
scm_array_handle_elements (scm_t_array_handle *h)
{
SCM vec = h->array;
if (SCM_ARRAYP (vec))
vec = SCM_ARRAY_V (vec);
if (SCM_I_IS_VECTOR (vec))
return SCM_I_VECTOR_ELTS (vec) + h->base;
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
}
SCM *
scm_array_handle_writable_elements (scm_t_array_handle *h)
{
SCM vec = h->array;
if (SCM_ARRAYP (vec))
vec = SCM_ARRAY_V (vec);
if (SCM_I_IS_VECTOR (vec))
return SCM_I_VECTOR_WELTS (vec) + h->base;
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
}
void
scm_vector_get_handle (SCM vec, scm_t_array_handle *h)
{
scm_array_get_handle (vec, h);
if (scm_array_handle_rank (h) != 1)
scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
}
const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
scm_vector_get_handle (vec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_elements (h);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
scm_vector_get_handle (vec, h);
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_writable_elements (h);
}
#if SCM_ENABLE_DEPRECATED
SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
@ -281,16 +397,24 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
scm_is_array or scm_is_typed_array anyway.
*/
SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
(SCM obj, SCM unused),
static SCM scm_i_array_p (SCM obj);
SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
"not.")
#define FUNC_NAME s_scm_array_p
#define FUNC_NAME s_scm_i_array_p
{
return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME
SCM
scm_array_p (SCM obj, SCM prot)
{
return scm_from_bool (scm_is_array (obj));
}
#endif /* !SCM_ENABLE_DEPRECATED */
@ -708,7 +832,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
{
SCM v = SCM_ARRAY_V (ra);
unsigned long int length = scm_to_ulong (scm_uniform_vector_length (v));
size_t length = scm_c_generalized_vector_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
@ -745,7 +869,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
#define FUNC_NAME s_scm_transpose_array
{
SCM res, vargs;
SCM const *ve = &vargs;
scm_t_array_dim *s, *r;
int ndim, i, k;
@ -767,13 +890,13 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra))
{
vargs = scm_vector (args);
if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
ve = SCM_VELTS (vargs);
ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{
i = scm_to_signed_integer (ve[k], 0, SCM_ARRAY_NDIM(ra));
i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
0, SCM_ARRAY_NDIM(ra));
if (ndim < i)
ndim = i;
}
@ -788,7 +911,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
}
for (k = SCM_ARRAY_NDIM (ra); k--;)
{
i = scm_to_int (ve[k]);
i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
s = &(SCM_ARRAY_DIMS (ra)[k]);
r = &(SCM_ARRAY_DIMS (res)[i]);
if (r->ubnd < r->lbnd)
@ -859,7 +982,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
if (scm_is_generalized_vector (ra))
{
s->lbnd = 0;
s->ubnd = scm_to_long (scm_uniform_vector_length (ra)) - 1;
s->ubnd = scm_c_generalized_vector_length (ra) - 1;
s->inc = 1;
SCM_ARRAY_V (ra_inr) = ra;
SCM_ARRAY_BASE (ra_inr) = 0;
@ -1755,23 +1878,19 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
size_t ulen, i;
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
const scm_t_uint32 *indices;
/* assert that obj is a boolean.
*/
scm_to_bool (obj);
scm_frame_begin (0);
indices = scm_u32vector_elements (kv, &handle, &len, &inc);
for (i = 0; i < len; i++, indices += inc)
scm_c_bitvector_set_x (v, (size_t) *indices, obj);
ulen = scm_c_uniform_vector_length (kv);
indices = scm_u32vector_elements (kv);
scm_frame_uniform_vector_release_elements (kv);
for (i = 0; i < ulen; i++)
scm_c_bitvector_set_x (v, (size_t)indices[i], obj);
scm_frame_end ();
}
else
scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
@ -1833,23 +1952,20 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
}
else if (scm_is_true (scm_u32vector_p (kv)))
{
size_t count = 0, ulen, i;
size_t count = 0;
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
const scm_t_uint32 *indices;
int bit = scm_to_bool (obj);
scm_frame_begin (0);
indices = scm_u32vector_elements (kv, &handle, &len, &inc);
ulen = scm_c_uniform_vector_length (kv);
indices = scm_u32vector_elements (kv);
scm_frame_uniform_vector_release_elements (kv);
for (i = 0; i < ulen; i++)
if ((scm_is_true (scm_c_bitvector_ref (v, (size_t)indices[i])) != 0)
for (i = 0; i < len; i++, indices += inc)
if ((scm_is_true (scm_c_bitvector_ref (v, (size_t) *indices)) != 0)
== (bit != 0))
count++;
scm_frame_end ();
return scm_from_size_t (count);
}
else

34
libguile/unif.h
View file

@ -105,6 +105,29 @@ SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_i_read_array (SCM port, int c);
typedef struct {
SCM array;
size_t base;
scm_t_array_dim *dims;
scm_t_array_dim dim0;
} scm_t_array_handle;
SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h);
SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h);
SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, size_t pos);
SCM_API void scm_array_handle_set (scm_t_array_handle *h, size_t pos, SCM val);
SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h);
SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h);
SCM_API void scm_vector_get_handle (SCM vec, scm_t_array_handle *h);
SCM_API const SCM *scm_vector_elements (SCM vec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
SCM_API SCM *scm_vector_writable_elements (SCM vec,
scm_t_array_handle *h,
size_t *lenp, ssize_t *incp);
/** Bit vectors */
@ -138,17 +161,22 @@ SCM_API void scm_frame_bitvector_release_writable_elements (SCM vec);
/* deprecated. */
#if SCM_ENABLE_DEPRECATED
SCM_API SCM scm_make_uve (long k, SCM prot);
SCM_API SCM scm_array_prototype (SCM ra);
SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill);
#endif
SCM_API SCM scm_make_ra (int ndim);
SCM_API void scm_ra_set_contp (SCM ra);
SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last);
SCM_API SCM scm_istr2bve (SCM str);
SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate);
SCM_API SCM scm_array_prototype (SCM ra);
SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
SCM_API long scm_aind (SCM ra, SCM args, const char *what);
SCM_API SCM scm_shap2ra (SCM args, const char *what);
SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill);
SCM_API SCM scm_ra2contig (SCM ra, int copy);
SCM_API SCM scm_i_cvref (SCM v, size_t p, int enclosed);

366
libguile/vectors.c
View file

@ -32,60 +32,84 @@
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"
#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
#if SCM_ENABLE_DEPRECATED
int
SCM_VECTORP (SCM x)
{
scm_c_issue_deprecation_warning
("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
return SCM_I_IS_VECTOR (x);
}
unsigned long
SCM_VECTOR_LENGTH (SCM x)
{
scm_c_issue_deprecation_warning
("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
return SCM_I_VECTOR_LENGTH (x);
}
const SCM *
SCM_VELTS (SCM x)
{
scm_c_issue_deprecation_warning
("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
return SCM_I_VECTOR_ELTS (x);
}
SCM *
SCM_WRITABLE_VELTS (SCM x)
{
scm_c_issue_deprecation_warning
("SCM_WRITABLE_VELTS is deprecated. "
"Use scm_vector_writable_elements instead.");
return SCM_I_VECTOR_WELTS (x);
}
SCM
SCM_VECTOR_REF (SCM x, size_t idx)
{
scm_c_issue_deprecation_warning
("SCM_VECTOR_REF is deprecated. "
"Use scm_c_vector_ref or scm_vector_elements instead.");
return scm_c_vector_ref (x, idx);
}
void
SCM_VECTOR_SET (SCM x, size_t idx, SCM val)
{
scm_c_issue_deprecation_warning
("SCM_VECTOR_SET is deprecated. "
"Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
scm_c_vector_set_x (x, idx, val);
}
#endif
int
scm_is_vector (SCM obj)
{
return (SCM_VECTORP (obj)
|| (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1));
if (SCM_I_IS_VECTOR (obj))
return 1;
if (SCM_ARRAYP (obj) && SCM_ARRAY_NDIM (obj) == 1)
{
SCM v = SCM_ARRAY_V (obj);
return SCM_I_IS_VECTOR (v);
}
return 0;
}
SCM *
scm_vector_writable_elements (SCM vec)
int
scm_is_simple_vector (SCM obj)
{
if (SCM_VECTORP (vec))
return SCM_WRITABLE_VELTS (vec);
else
scm_wrong_type_arg_msg (NULL, 0, vec, "simple vector");
}
const SCM *
scm_vector_elements (SCM vec)
{
if (SCM_VECTORP (vec))
return SCM_VELTS (vec);
else
scm_wrong_type_arg_msg (NULL, 0, vec, "simple vector");
}
void
scm_vector_release_writable_elements (SCM vec)
{
scm_remember_upto_here_1 (vec);
}
void
scm_vector_release_elements (SCM vec)
{
scm_remember_upto_here_1 (vec);
}
void
scm_frame_vector_release_writable_elements (SCM vec)
{
scm_frame_unwind_handler_with_scm
(scm_vector_release_writable_elements, vec,
SCM_F_WIND_EXPLICITLY);
}
void
scm_frame_vector_release_elements (SCM vec)
{
scm_frame_unwind_handler_with_scm
(scm_vector_release_elements, vec,
SCM_F_WIND_EXPLICITLY);
return SCM_I_IS_VECTOR (obj);
}
SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
@ -103,8 +127,8 @@ SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vecto
SCM
scm_vector_length (SCM v)
{
if (SCM_VECTORP (v))
return scm_from_size_t (SCM_VECTOR_LENGTH (v));
if (SCM_I_IS_VECTOR (v))
return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
else if (SCM_ARRAYP (v) && SCM_ARRAY_NDIM (v) == 1)
{
scm_t_array_dim *dim = SCM_ARRAY_DIMS (v);
@ -117,8 +141,8 @@ scm_vector_length (SCM v)
size_t
scm_c_vector_length (SCM v)
{
if (SCM_VECTORP (v))
return SCM_VECTOR_LENGTH (v);
if (SCM_I_IS_VECTOR (v))
return SCM_I_VECTOR_LENGTH (v);
else
return scm_to_size_t (scm_vector_length (v));
}
@ -146,19 +170,19 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM res;
SCM *data;
long i, len;
scm_t_array_handle handle;
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
data = scm_vector_writable_elements (res);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
data = scm_vector_writable_elements (res, &handle, NULL, NULL);
i = 0;
while (!SCM_NULL_OR_NIL_P (l) && i < len)
{
data[i] = SCM_CAR (l);
l = SCM_CDR (l);
i++;
i += 1;
}
scm_vector_release_writable_elements (res);
return res;
}
@ -191,19 +215,24 @@ scm_vector_ref (SCM v, SCM k)
SCM
scm_c_vector_ref (SCM v, size_t k)
{
if (SCM_VECTORP (v))
if (SCM_I_IS_VECTOR (v))
{
if (k >= SCM_VECTOR_LENGTH (v))
if (k >= SCM_I_VECTOR_LENGTH (v))
scm_out_of_range (NULL, scm_from_size_t (k));
return SCM_VECTOR_REF (v, k);
return (SCM_I_VECTOR_ELTS(v))[k];
}
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;
return scm_c_generalized_vector_ref (SCM_ARRAY_V (v), k);
SCM vv = SCM_ARRAY_V (v);
if (SCM_I_IS_VECTOR (vv))
{
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_I_VECTOR_ELTS (vv))[k];
}
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
@ -234,19 +263,25 @@ scm_vector_set_x (SCM v, SCM k, SCM obj)
void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
if (SCM_VECTORP (v))
if (SCM_I_IS_VECTOR (v))
{
if (k >= SCM_VECTOR_LENGTH (v))
if (k >= SCM_I_VECTOR_LENGTH (v))
scm_out_of_range (NULL, scm_from_size_t (k));
SCM_VECTOR_SET (v, k, obj);
(SCM_I_VECTOR_WELTS(v))[k] = obj;
}
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);
SCM vv = SCM_ARRAY_V (v);
if (SCM_I_IS_VECTOR (vv))
{
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_I_VECTOR_WELTS (vv))[k] = obj;
}
else
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
{
@ -266,7 +301,7 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
"unspecified.")
#define FUNC_NAME s_scm_make_vector
{
size_t l = scm_to_unsigned_integer (k, 0, SCM_VECTOR_MAX_LENGTH);
size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
if (SCM_UNBNDP (fill))
fill = SCM_UNSPECIFIED;
@ -281,28 +316,92 @@ scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
SCM v;
scm_t_bits *base;
SCM *base;
if (k > 0)
{
unsigned long int j;
SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= SCM_VECTOR_MAX_LENGTH);
SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
base = scm_gc_malloc (k * sizeof (scm_t_bits), "vector");
base = scm_gc_malloc (k * sizeof (SCM), "vector");
for (j = 0; j != k; ++j)
base[j] = SCM_UNPACK (fill);
base[j] = fill;
}
else
base = NULL;
v = scm_cell (SCM_MAKE_VECTOR_TAG (k, scm_tc7_vector), (scm_t_bits) base);
v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
scm_remember_upto_here_1 (fill);
return v;
}
#undef FUNC_NAME
SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
(SCM vec),
"Return a copy of @var{vec}.")
#define FUNC_NAME s_scm_vector_copy
{
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
const SCM *src;
SCM *dst;
src = scm_vector_elements (vec, &handle, &len, &inc);
dst = scm_gc_malloc (len * sizeof (SCM), "vector");
for (i = 0; i < len; i++, src += inc)
dst[i] = *src;
return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
}
#undef FUNC_NAME
void
scm_i_vector_free (SCM vec)
{
scm_gc_free (SCM_I_VECTOR_WELTS (vec),
SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
"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)
{
size_t c_size;
SCM *base;
SCM v;
c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
if (c_size > 0)
{
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;
}
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);
return v;
}
SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM v),
@ -314,21 +413,19 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_vector_to_list
{
if (SCM_VECTORP (v))
SCM res = SCM_EOL;
const SCM *data;
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
data = scm_vector_elements (v, &handle, &len, &inc);
for (i = len*inc; i > 0;)
{
SCM res = SCM_EOL;
long i;
const SCM *data;
data = scm_vector_elements (v);
for(i = SCM_VECTOR_LENGTH(v)-1; i >= 0; i--)
res = scm_cons (data[i], res);
scm_vector_release_elements (v);
return res;
i -= inc;
res = scm_cons (data[i], 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");
return res;
}
#undef FUNC_NAME
@ -339,18 +436,15 @@ 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
{
if (SCM_VECTORP (v))
{
size_t i, len;
SCM *elts = scm_vector_writable_elements (v);
for (i = 0, len = SCM_VECTOR_LENGTH (v); i < len; i++)
elts[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");
scm_t_array_handle handle;
SCM *data;
size_t i, len;
ssize_t inc;
data = scm_vector_writable_elements (v, &handle, &len, &inc);
for (i = 0; i < len; i += inc)
data[i] = fill;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -359,8 +453,9 @@ SCM
scm_vector_equal_p (SCM x, SCM y)
{
long i;
for (i = SCM_VECTOR_LENGTH (x) - 1; i >= 0; i--)
if (scm_is_false (scm_equal_p (SCM_VELTS (x)[i], SCM_VELTS (y)[i])))
for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
SCM_I_VECTOR_ELTS (y)[i])))
return SCM_BOOL_F;
return SCM_BOOL_T;
}
@ -377,32 +472,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
{
scm_t_array_handle handle1, handle2;
const SCM *elts1;
SCM *elts2;
size_t len1, len2;
ssize_t inc1, inc2;
size_t i, j, e;
elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
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 simple vectors.
*/
if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2))
{
const SCM *elts1 = scm_vector_elements (vec1);
SCM *elts2 = scm_vector_writable_elements (vec2);
for (; i < e; i++, j++)
elts2[j] = elts1[i];
scm_vector_release_elements (vec1);
scm_vector_release_writable_elements (vec2);
}
else
{
for (; i < e; i++, j++)
scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, i));
}
i *= inc1;
e *= inc1;
j *= inc2;
for (; i < e; i += inc1, j += inc2)
elts2[j] = elts1[i];
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -418,39 +507,30 @@ 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
{
scm_t_array_handle handle1, handle2;
const SCM *elts1;
SCM *elts2;
size_t len1, len2;
ssize_t inc1, inc2;
size_t i, j, e;
elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
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;
if (SCM_VECTORP (vec1) && SCM_VECTORP (vec2))
i *= inc1;
e *= inc1;
j *= inc2;
while (i < e)
{
const SCM *elts1 = scm_vector_elements (vec1);
SCM *elts2 = scm_vector_writable_elements (vec2);
while (i < e)
{
e--, j--;
elts2[j] = elts1[e];
}
scm_vector_release_elements (vec1);
scm_vector_release_writable_elements (vec2);
e -= inc1;
j -= inc2;
elts2[j] = elts1[e];
}
else
{
while (i < e)
{
e--, j--;
scm_c_vector_set_x (vec2, j, scm_c_vector_ref (vec1, e));
}
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

78
libguile/vectors.h
View file

@ -23,31 +23,10 @@
#include "libguile/__scm.h"
#include "libguile/unif.h"
#define SCM_VECTORP(x) (!SCM_IMP (x) && (SCM_TYP7S (x) == scm_tc7_vector))
#define SCM_VECTOR_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x))
#define SCM_SET_VECTOR_BASE(v, b) (SCM_SET_CELL_WORD_1 ((v), (b)))
#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
#define SCM_VECTOR_LENGTH(x) (((unsigned long) SCM_CELL_WORD_0 (x)) >> 8)
#define SCM_MAKE_VECTOR_TAG(l, t) (((l) << 8) + (t))
#define SCM_SET_VECTOR_LENGTH(v, l, t) (SCM_SET_CELL_WORD_0 ((v), SCM_MAKE_VECTOR_TAG(l, t)))
#define SCM_VELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x))
#define SCM_VELTS_AS_STACKITEMS(x) ((SCM_STACKITEM *) SCM_CELL_WORD_1 (x))
#define SCM_SETVELTS(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
#define SCM_VECTOR_REF(x, idx) (((const SCM *) SCM_CELL_WORD_1 (x))[(idx)])
#define SCM_VECTOR_SET(x, idx, val) (((SCM*)SCM_CELL_WORD_1 (x))[(idx)] = (val))
#define SCM_GC_WRITABLE_VELTS(x) ((SCM*) SCM_VELTS(x))
/*
no WB yet.
*/
#define SCM_WRITABLE_VELTS(x) ((SCM*) SCM_VELTS(x))
/*
bit vectors
*/
@ -55,6 +34,8 @@
#define SCM_BITVEC_SET(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] |= (1L << ((i) % SCM_LONG_BIT))
#define SCM_BITVEC_CLR(a, i) SCM_BITVECTOR_BASE (a) [(i) / SCM_LONG_BIT] &= ~(1L << ((i) % SCM_LONG_BIT))
@ -70,18 +51,21 @@ SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1,
SCM vec2, SCM start2);
SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1,
SCM vec2, SCM start2);
SCM_API SCM scm_vector_copy (SCM vec);
SCM_API int scm_is_vector (SCM obj);
SCM_API int scm_is_simple_vector (SCM obj);
SCM_API SCM scm_c_make_vector (size_t len, SCM fill);
SCM_API size_t scm_c_vector_length (SCM vec);
SCM_API SCM scm_c_vector_ref (SCM vec, size_t k);
SCM_API void scm_c_vector_set_x (SCM vec, size_t k, SCM obj);
SCM_API const SCM *scm_vector_elements (SCM vec);
SCM_API void scm_vector_release_elements (SCM vec);
SCM_API void scm_frame_vector_release_elements (SCM vec);
SCM_API SCM *scm_vector_writable_elements (SCM vec);
SCM_API void scm_vector_release_writable_elements (SCM vec);
SCM_API void scm_frame_vector_release_writable_elements (SCM vec);
/* Fast, non-checking accessors for simple vectors.
*/
#define SCM_SIMPLE_VECTOR_LENGTH(x) SCM_I_VECTOR_LENGTH(x)
#define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx])
#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val))
#define SCM_SIMPLE_VECTOR_LOC(x,idx) (&((SCM_I_VECTOR_WELTS(x))[idx]))
/* Generalized vectors */
@ -98,8 +82,46 @@ SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
/* Deprecated */
#if SCM_ENABLE_DEPRECATED
#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
SCM_API int SCM_VECTORP (SCM x);
SCM_API unsigned long SCM_VECTOR_LENGTH (SCM x);
SCM_API const SCM *SCM_VELTS (SCM x);
SCM_API SCM *SCM_WRITABLE_VELTS (SCM x);
SCM_API SCM SCM_VECTOR_REF (SCM x, size_t idx);
SCM_API void SCM_VECTOR_SET (SCM x, size_t idx, SCM val);
#endif
SCM_API SCM scm_vector_equal_p (SCM x, SCM y);
/* Internals */
#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x))
#define SCM_I_VECTOR_WELTS(x) ((SCM *) SCM_CELL_WORD_1 (x))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
SCM_API void scm_i_vector_free (SCM vec);
/* Weak vectors share implementation details with ordinary vectors,
but no one else should. Weak vectors need to be cleaned up as
well.
*/
#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \
SCM_TYP7 (x) == scm_tc7_wvect)
#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
#define SCM_I_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x))
#define SCM_I_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X))
#define SCM_I_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o)))
SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill);
SCM_API void scm_init_vectors (void);
#endif /* SCM_VECTORS_H */

92
libguile/weaks.c
View file

@ -66,49 +66,6 @@
*/
/* 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, const char* caller)
#define FUNC_NAME caller
{
size_t c_size;
SCM v;
c_size = scm_to_unsigned_integer (size, 0, SCM_VECTOR_MAX_LENGTH);
if (c_size > 0)
{
scm_t_bits *base;
size_t j;
if (SCM_UNBNDP (fill))
fill = SCM_UNSPECIFIED;
base = scm_gc_malloc (c_size * sizeof (scm_t_bits), "weak vector");
for (j = 0; j != c_size; ++j)
base[j] = SCM_UNPACK (fill);
v = scm_double_cell (SCM_MAKE_VECTOR_TAG (c_size, scm_tc7_wvect),
(scm_t_bits) base,
type,
SCM_UNPACK (SCM_EOL));
scm_remember_upto_here_1 (fill);
}
else
{
v = scm_double_cell (SCM_MAKE_VECTOR_TAG (0, scm_tc7_wvect),
(scm_t_bits) NULL,
type,
SCM_UNPACK (SCM_EOL));
}
return v;
}
#undef FUNC_NAME
SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
(SCM size, SCM fill),
"Return a weak vector with @var{size} elements. If the optional\n"
@ -117,7 +74,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
"empty list.")
#define FUNC_NAME s_scm_make_weak_vector
{
return scm_i_allocate_weak_vector (0, size, fill, FUNC_NAME);
return scm_i_allocate_weak_vector (0, size, fill);
}
#undef FUNC_NAME
@ -133,24 +90,21 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
"the same way @code{list->vector} would.")
#define FUNC_NAME s_scm_weak_vector
{
SCM res;
SCM *data;
scm_t_array_handle handle;
SCM res, *data;
long i;
/* Dirk:FIXME:: In case of multiple threads, the list might get corrupted
while the vector is being created. */
i = scm_ilength (l);
SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
/*
no alloc, so this loop is safe.
*/
data = SCM_WRITABLE_VELTS (res);
while (!SCM_NULL_OR_NIL_P (l))
res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
data = scm_vector_writable_elements (res, &handle, NULL, NULL);
while (scm_is_pair (l) && i > 0)
{
*data++ = SCM_CAR (l);
l = SCM_CDR (l);
i--;
}
return res;
@ -164,7 +118,7 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
"weak hashes are also weak vectors.")
#define FUNC_NAME s_scm_weak_vector_p
{
return scm_from_bool (SCM_WVECTP (obj) && !SCM_IS_WHVEC (obj));
return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
}
#undef FUNC_NAME
@ -183,7 +137,7 @@ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1,
#define FUNC_NAME s_scm_make_weak_key_alist_vector
{
return scm_i_allocate_weak_vector
(1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME);
(1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME
@ -195,7 +149,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0,
#define FUNC_NAME s_scm_make_weak_value_alist_vector
{
return scm_i_allocate_weak_vector
(2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME);
(2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME
@ -207,7 +161,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector",
#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
{
return scm_i_allocate_weak_vector
(3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL, FUNC_NAME);
(3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
}
#undef FUNC_NAME
@ -221,7 +175,7 @@ SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
"nor a weak value hash table.")
#define FUNC_NAME s_scm_weak_key_alist_vector_p
{
return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC (obj));
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
}
#undef FUNC_NAME
@ -231,7 +185,7 @@ SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a weak value hash table.")
#define FUNC_NAME s_scm_weak_value_alist_vector_p
{
return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
}
#undef FUNC_NAME
@ -241,7 +195,7 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0
"Return @code{#t} if @var{obj} is a doubly weak hash table.")
#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
{
return scm_from_bool (SCM_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
}
#undef FUNC_NAME
@ -264,7 +218,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
{
SCM w;
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_WVECT_GC_CHAIN (w))
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w))
{
if (SCM_IS_WHVEC_ANY (w))
{
@ -274,8 +228,8 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
long n;
obj = w;
ptr = SCM_VELTS (w);
n = SCM_VECTOR_LENGTH (w);
ptr = SCM_I_WVECT_GC_WVELTS (w);
n = SCM_I_WVECT_LENGTH (w);
for (j = 0; j < n; ++j)
{
SCM alist;
@ -304,14 +258,14 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
SCM *ptr, w;
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_WVECT_GC_CHAIN (w))
for (w = scm_weak_vectors; !scm_is_null (w); w = SCM_I_WVECT_GC_CHAIN (w))
{
if (!SCM_IS_WHVEC_ANY (w))
{
register long j, n;
ptr = SCM_GC_WRITABLE_VELTS (w);
n = SCM_VECTOR_LENGTH (w);
ptr = SCM_I_WVECT_GC_WVELTS (w);
n = SCM_I_WVECT_LENGTH (w);
for (j = 0; j < n; ++j)
if (UNMARKED_CELL_P (ptr[j]))
ptr[j] = SCM_BOOL_F;
@ -321,12 +275,12 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
else if (!SCM_WVECT_NOSCAN_P (w))
{
SCM obj = w;
register long n = SCM_VECTOR_LENGTH (w);
register long n = SCM_I_WVECT_LENGTH (w);
register long j;
int weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
int weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
ptr = SCM_GC_WRITABLE_VELTS (w);
ptr = SCM_I_WVECT_GC_WVELTS (w);
for (j = 0; j < n; ++j)
{

20
libguile/weaks.h
View file

@ -30,24 +30,18 @@
#define SCM_WVECTF_WEAK_VALUE 2
#define SCM_WVECTF_NOSCAN 4
#define SCM_WVECTP(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_wvect)
#define SCM_WVECT_TYPE(x) (SCM_CELL_WORD_2 (x))
#define SCM_SET_WVECT_TYPE(x, t) (SCM_SET_CELL_WORD_2 ((x), (t)))
#define SCM_WVECT_WEAK_KEY_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_WEAK_KEY)
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_WEAK_VALUE)
#define SCM_WVECT_NOSCAN_P(x) (SCM_WVECT_TYPE (x) & SCM_WVECTF_NOSCAN)
#define SCM_IS_WHVEC(X) (SCM_WVECT_TYPE (X) == 1)
#define SCM_IS_WHVEC_V(X) (SCM_WVECT_TYPE (X) == 2)
#define SCM_IS_WHVEC_B(X) (SCM_WVECT_TYPE (X) == 3)
#define SCM_IS_WHVEC_ANY(X) (SCM_WVECT_TYPE (X) != 0)
#define SCM_WVECT_GC_CHAIN(X) (SCM_CELL_OBJECT_3 (X))
#define SCM_SET_WVECT_GC_CHAIN(X, o) (SCM_SET_CELL_OBJECT_3 ((X), (o)))
#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_KEY)
#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_TYPE(x) & SCM_WVECTF_WEAK_VALUE)
#define SCM_WVECT_NOSCAN_P(x) (SCM_I_WVECT_TYPE (x) & SCM_WVECTF_NOSCAN)
#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
SCM_API SCM scm_weak_vectors;
SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill, const char* caller);
SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
SCM_API SCM scm_weak_vector (SCM l);
SCM_API SCM scm_weak_vector_p (SCM x);