summaryrefslogtreecommitdiff
path: root/libguile/srfi-4.c
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2005-01-02 20:06:08 +0000
committerMarius Vollmer <mvo@zagadka.de>2005-01-02 20:06:08 +0000
commit6e708ef2b1897c3ea4d5ac47720974078d50e9e4 (patch)
tree3dde367b768213b4693cc586b2adf23074f15667 /libguile/srfi-4.c
parent9c6e33c62acc203792053b6d5a579bdc22827eec (diff)
downloadguile-6e708ef2b1897c3ea4d5ac47720974078d50e9e4.tar.gz
* weaks.c: Use new vector elements API or simple vector
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.
Diffstat (limited to 'libguile/srfi-4.c')
-rw-r--r--libguile/srfi-4.c144
1 files changed, 68 insertions, 76 deletions
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 32b1b23d2..61995c662 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -584,85 +584,68 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
}
#undef FUNC_NAME
-const void *
-scm_uniform_vector_elements (SCM uvec)
+size_t
+scm_uniform_vector_element_size (SCM uvec)
{
if (scm_is_uniform_vector (uvec))
- return SCM_UVEC_BASE (uvec);
+ return uvec_sizes[SCM_UVEC_TYPE (uvec)];
else
scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}
-
-void
-scm_uniform_vector_release_elements (SCM uvec)
+
+/* return the size of an element in a uniform array or 0 if type not
+ found. */
+size_t
+scm_uniform_element_size (SCM obj)
{
- /* 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);
+ if (scm_is_uniform_vector (obj))
+ return scm_uniform_vector_element_size (obj);
+ else
+ return 0;
}
-void
-scm_frame_uniform_vector_release_elements (SCM uvec)
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
{
- scm_frame_unwind_handler_with_scm (scm_uniform_vector_release_elements, uvec,
- SCM_F_WIND_EXPLICITLY);
+ return scm_array_handle_uniform_writable_elements (h);
}
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)
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
- /* 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);
+ 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");
}
-void
-scm_frame_uniform_vector_release_writable_elements (SCM uvec)
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
{
- scm_frame_unwind_handler_with_scm
- (scm_uniform_vector_release_writable_elements, uvec,
- SCM_F_WIND_EXPLICITLY);
+ return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
}
-size_t
-scm_uniform_vector_element_size (SCM uvec)
-{
- if (scm_is_uniform_vector (uvec))
- return uvec_sizes[SCM_UVEC_TYPE (uvec)];
- else
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-}
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
+void *
+scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
{
- if (scm_is_uniform_vector (obj))
- return scm_uniform_vector_element_size (obj);
- else
- return 0;
+ 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,
@@ -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