diff options
author | Christine Lemmer-Webber <cwebber@dustycloud.org> | 2021-10-10 20:59:04 -0400 |
---|---|---|
committer | Christine Lemmer-Webber <cwebber@dustycloud.org> | 2021-10-10 20:59:04 -0400 |
commit | 204cb986469b2751a3c3347a34a8013c1a0b6954 (patch) | |
tree | e91534db67add400e5213ec3becb6ab48544b470 /libguile/vectors.c | |
parent | b03b359b5b16c040c485a565f3ce92481ea43f41 (diff) | |
parent | e60469c8b6936575c079faaffa40a340e1d49f3c (diff) | |
download | guile-204cb986469b2751a3c3347a34a8013c1a0b6954.tar.gz |
Merge branch 'main' into compile-to-js-merge
Diffstat (limited to 'libguile/vectors.c')
-rw-r--r-- | libguile/vectors.c | 356 |
1 files changed, 248 insertions, 108 deletions
diff --git a/libguile/vectors.c b/libguile/vectors.c index 0f1e6085e..8cbd201f5 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -24,19 +24,20 @@ # include <config.h> #endif +#include <string.h> + #include "array-handle.h" #include "bdw-gc.h" #include "boolean.h" +#include "deprecation.h" #include "eq.h" +#include "generalized-vectors.h" #include "gsubr.h" #include "list.h" #include "numbers.h" #include "pairs.h" #include "vectors.h" -#include "generalized-vectors.h" - - #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) @@ -54,21 +55,15 @@ scm_is_vector (SCM obj) return SCM_I_IS_VECTOR (obj); } -int -scm_is_simple_vector (SCM obj) -{ - return SCM_I_IS_VECTOR (obj); -} - const SCM * -scm_vector_elements (SCM vec, scm_t_array_handle *h, +scm_vector_elements (SCM array, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { - scm_array_get_handle (vec, h); + scm_array_get_handle (array, h); if (1 != scm_array_handle_rank (h)) { scm_array_handle_release (h); - scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array of Scheme values"); + scm_wrong_type_arg_msg (NULL, 0, array, "rank 1 array of Scheme values"); } if (lenp) @@ -81,13 +76,13 @@ scm_vector_elements (SCM vec, scm_t_array_handle *h, } SCM * -scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, +scm_vector_writable_elements (SCM array, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { - const SCM *ret = scm_vector_elements (vec, h, lenp, incp); + const SCM *ret = scm_vector_elements (array, h, lenp, incp); if (h->writable_elements != h->elements) - scm_wrong_type_arg_msg (NULL, 0, vec, "mutable vector"); + scm_wrong_type_arg_msg (NULL, 0, array, "mutable rank 1 array of Scheme values"); return (SCM *) ret; } @@ -264,34 +259,116 @@ scm_c_make_vector (size_t k, SCM fill) } #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_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0, + (SCM vec, SCM start, SCM end), + "Returns a freshly allocated vector containing the elements\n" + "of @var{vec} between @var{start} and @var{end}.\n\n" + "@var{start} defaults to 0 and @var{end} defaults to the\n" + "length of @var{vec}.") +#define FUNC_NAME s_scm_vector_copy_partial { - scm_t_array_handle handle; - size_t i, len; - ssize_t inc; - const SCM *src; - SCM result, *dst; + SCM result; + if (SCM_I_IS_VECTOR (vec)) + { + size_t cstart = 0, cend = SCM_I_VECTOR_LENGTH (vec); + + if (!SCM_UNBNDP (start)) + { + cstart = scm_to_size_t (start); + SCM_ASSERT_RANGE (SCM_ARG2, start, cstart<=cend); + + if (!SCM_UNBNDP (end)) + { + size_t e = scm_to_size_t (end); + SCM_ASSERT_RANGE (SCM_ARG3, end, e>=cstart && e<=cend); + cend = e; + } + } + + size_t len = cend-cstart; + result = make_vector (len); + memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec) + cstart, + len * sizeof(SCM)); + } + else + { + 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); + scm_c_issue_deprecation_warning + ("Using vector-copy on arrays is deprecated. " + "Use array-copy instead."); + + if (SCM_UNBNDP (start)) + scm_misc_error (s_scm_vector_copy_partial, "Too many arguments", SCM_EOL); + + result = make_vector (len); + dst = SCM_I_VECTOR_WELTS (result); + for (i = 0; i < len; i++, src += inc) + dst[i] = *src; + + scm_array_handle_release (&handle); + } + return result; +} +#undef FUNC_NAME - src = scm_vector_elements (vec, &handle, &len, &inc); +SCM +scm_vector_copy (SCM vec) +{ + return scm_vector_copy_partial (vec, SCM_UNDEFINED, SCM_UNDEFINED); +} - result = make_vector (len); - dst = SCM_I_VECTOR_WELTS (result); - for (i = 0; i < len; i++, src += inc) - dst[i] = *src; +SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0, + (SCM dst, SCM at, SCM src, SCM start, SCM end), + "Copy a block of elements from @var{src} to @var{dst}, both of which must be\n" + "vectors, starting in @var{dst} at @var{at} and starting in @var{src} at\n" + "@var{start} and ending at @var{end}.\n\n" + "It is an error for @var{dst} to have a length less than\n" + "@var{at} + (@var{end} - @var{start}). @var{at} and @var{start} default\n" + "to 0 and @var{end} defaults to the length of @var{src}.\n\n" + "The order in which elements are copied is unspecified, except that if the\n" + "source and destination overlap, copying takes place as if the source is\n" + "first copied into a temporary vector and then into the destination.") +#define FUNC_NAME s_scm_vector_copy_x +{ + SCM_VALIDATE_MUTABLE_VECTOR (1, dst); + SCM_VALIDATE_VECTOR (3, src); + size_t src_org = 0; + size_t dst_org = scm_to_size_t (at); + size_t src_end = SCM_I_VECTOR_LENGTH (src); + size_t dst_end = SCM_I_VECTOR_LENGTH (dst); - scm_array_handle_release (&handle); + if (!SCM_UNBNDP (start)) + { + src_org = scm_to_size_t (start); + SCM_ASSERT_RANGE (SCM_ARG4, start, src_org<=src_end); + + if (!SCM_UNBNDP (end)) + { + size_t e = scm_to_size_t (end); + SCM_ASSERT_RANGE (SCM_ARG5, end, e>=src_org && e<=src_end); + src_end = e; + } + } + size_t len = src_end-src_org; + SCM_ASSERT_RANGE (SCM_ARG2, at, dst_org<=dst_end && len<=dst_end-dst_org); - return result; + memmove (SCM_I_VECTOR_WELTS (dst) + dst_org, SCM_I_VECTOR_ELTS (src) + src_org, + len * sizeof(SCM)); + + return SCM_UNSPECIFIED; } #undef FUNC_NAME 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" + (SCM vec), + "Return a newly allocated list composed of the elements of @var{vec}.\n" "\n" "@lisp\n" "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n" @@ -300,18 +377,33 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, #define FUNC_NAME s_scm_vector_to_list { SCM res = SCM_EOL; - const SCM *data; - scm_t_array_handle handle; - size_t i, count, len; - ssize_t inc; - - data = scm_vector_elements (v, &handle, &len, &inc); - for (i = (len - 1) * inc, count = 0; - count < len; - i -= inc, count++) - res = scm_cons (data[i], res); - - scm_array_handle_release (&handle); + + if (SCM_I_IS_VECTOR (vec)) + { + ssize_t len = SCM_I_VECTOR_LENGTH (vec); + const SCM * data = SCM_I_VECTOR_ELTS (vec); + for (ssize_t i = len-1; i >= 0; --i) + res = scm_cons (data[i], res); + } + else + { + const SCM *data; + scm_t_array_handle handle; + size_t i, count, len; + ssize_t inc; + + data = scm_vector_elements (vec, &handle, &len, &inc); + scm_c_issue_deprecation_warning + ("Using vector->list on arrays is deprecated. " + "Use array->list instead."); + + for (i = (len - 1) * inc, count = 0; + count < len; + i -= inc, count++) + res = scm_cons (data[i], res); + + scm_array_handle_release (&handle); + } return res; } #undef FUNC_NAME @@ -320,27 +412,24 @@ static SCM scm_vector_fill_partial_x (SCM vec, SCM fill, SCM start, SCM end); SCM_DEFINE_STATIC (scm_vector_fill_partial_x, "vector-fill!", 2, 2, 0, (SCM vec, SCM fill, SCM start, SCM end), - "Assign the value of every location in vector @var{vec} between\n" - "@var{start} and @var{end} to @var{fill}. @var{start} defaults\n" + "Assign the value of every location in vector @var{vec} in the range\n" + "[@var{start} ... @var{end}) to @var{fill}. @var{start} defaults\n" "to 0 and @var{end} defaults to the length of @var{vec}. The value\n" "returned by @code{vector-fill!} is unspecified.") #define FUNC_NAME s_scm_vector_fill_partial_x { SCM_VALIDATE_MUTABLE_VECTOR(1, vec); - SCM *data; size_t i = 0; - size_t len = SCM_I_VECTOR_LENGTH (vec); - - data = SCM_I_VECTOR_WELTS (vec); + size_t c_end = SCM_I_VECTOR_LENGTH (vec); + SCM *data = SCM_I_VECTOR_WELTS (vec); if (!SCM_UNBNDP (start)) - i = scm_to_unsigned_integer (start, 0, len); - + i = scm_to_unsigned_integer (start, 0, c_end); if (!SCM_UNBNDP (end)) - len = scm_to_unsigned_integer (end, i, len); + c_end = scm_to_unsigned_integer (end, i, c_end); - for (; i < len; ++i) + for (; i < c_end; ++i) data[i] = fill; return SCM_UNSPECIFIED; @@ -380,31 +469,53 @@ 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); - - i = scm_to_unsigned_integer (start1, 0, len1); - e = scm_to_unsigned_integer (end1, i, len1); - SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); - j = scm_to_unsigned_integer (start2, 0, len2); - SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); - - i *= inc1; - e *= inc1; - j *= inc2; - for (; i < e; i += inc1, j += inc2) - elts2[j] = elts1[i]; - - scm_array_handle_release (&handle2); - scm_array_handle_release (&handle1); - + if (SCM_I_IS_VECTOR (vec1) && SCM_I_IS_VECTOR (vec2)) + { + SCM_VALIDATE_MUTABLE_VECTOR (1, vec2); + const SCM *elts1 = SCM_I_VECTOR_ELTS (vec1); + SCM *elts2 = SCM_I_VECTOR_WELTS (vec2); + size_t len1 = SCM_I_VECTOR_LENGTH (vec1); + size_t len2 = SCM_I_VECTOR_LENGTH (vec2); + + size_t i, j, e; + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); + for (; i < e; ++i, ++j) + elts2[j] = elts1[i]; + } + else + { + 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); + scm_c_issue_deprecation_warning + ("Using vector-move-left! on arrays is deprecated. " + "Use array-copy-in-order! instead."); + + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); + + i *= inc1; + e *= inc1; + j *= inc2; + for (; i < e; i += inc1, j += inc2) + elts2[j] = elts1[i]; + + scm_array_handle_release (&handle2); + scm_array_handle_release (&handle1); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -420,36 +531,65 @@ 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); - - i = scm_to_unsigned_integer (start1, 0, len1); - e = scm_to_unsigned_integer (end1, i, len1); - SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); - j = scm_to_unsigned_integer (start2, 0, len2); - SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); - - j += (e - i); - - i *= inc1; - e *= inc1; - j *= inc2; - while (i < e) + if (SCM_I_IS_VECTOR (vec1) && SCM_I_IS_VECTOR (vec2)) { - e -= inc1; - j -= inc2; - elts2[j] = elts1[e]; + SCM_VALIDATE_MUTABLE_VECTOR (1, vec2); + const SCM *elts1 = SCM_I_VECTOR_ELTS (vec1); + SCM *elts2 = SCM_I_VECTOR_WELTS (vec2); + size_t len1 = SCM_I_VECTOR_LENGTH (vec1); + size_t len2 = SCM_I_VECTOR_LENGTH (vec2); + + size_t i, j, e; + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); + j += (e - i); + + while (i < e) + { + --e; + --j; + elts2[j] = elts1[e]; + } + } + else + { + 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); + scm_c_issue_deprecation_warning + ("Using vector-move-right! on arrays is deprecated. " + "Use array-copy-in-order! instead."); + + i = scm_to_unsigned_integer (start1, 0, len1); + e = scm_to_unsigned_integer (end1, i, len1); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) <= len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); + + j += (e - i); + + i *= inc1; + e *= inc1; + j *= inc2; + while (i < e) + { + e -= inc1; + j -= inc2; + elts2[j] = elts1[e]; + } + + scm_array_handle_release (&handle2); + scm_array_handle_release (&handle1); } - - scm_array_handle_release (&handle2); - scm_array_handle_release (&handle1); return SCM_UNSPECIFIED; } |