diff --git a/configure.ac b/configure.ac index 40ebc6742..a2b9f41ad 100644 --- a/configure.ac +++ b/configure.ac @@ -241,10 +241,6 @@ AC_ARG_ENABLE(regex, [ --disable-regex omit regular expression interfaces],, enable_regex=yes) -AC_ARG_ENABLE(tmpnam, - AS_HELP_STRING([--disable-tmpnam],[omit POSIX tmpnam]),, - enable_tmpnam=yes) - AC_ARG_ENABLE([deprecated], AS_HELP_STRING([--disable-deprecated],[omit deprecated features])) @@ -997,10 +993,6 @@ if test "$enable_regex" = yes; then AC_DEFINE([ENABLE_REGEX], 1, [Define when regex support is enabled.]) fi -if test "$enable_tmpnam" = yes; then - AC_DEFINE([ENABLE_TMPNAM], 1, [Define when tmpnam support is enabled.]) -fi - AC_REPLACE_FUNCS([strerror memmove]) # Reasons for testing: diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 08d939b9f..01980b4f0 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -@c 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017, 2021 Free Software Foundation, Inc. +@c 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017, 2021, 2025 Free Software Foundation, Inc. @c Copyright (C) 2021 Maxime Devos @c See the file guile.texi for copying conditions. @@ -1070,24 +1070,6 @@ E.g., The return value is unspecified. @end deffn -@deffn {Scheme Procedure} tmpnam -@deffnx {C Function} scm_tmpnam () -@cindex temporary file -Return an auto-generated name of a temporary file, a file which -doesn't already exist. The name includes a path, it's usually in -@file{/tmp} but that's system dependent. - -Care must be taken when using @code{tmpnam}. In between choosing the -name and creating the file another program might use that name, or an -attacker might even make it a symlink pointing at something important -and causing you to overwrite that. - -The safe way is to create the file using @code{open} with -@code{O_EXCL} to avoid any overwriting. A loop can try again with -another name if the file exists (error @code{EEXIST}). -@code{mkstemp} below does that. -@end deffn - @deffn {Scheme Procedure} mkstemp tmpl [mode] @cindex temporary file Create a new unique file in the file system and return a new buffered diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 41b91a51b..ad3212a62 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1998,2000-2006,2009-2014,2018,2020 +/* Copyright 1995-1998,2000-2006,2009-2014,2018,2020,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -432,36 +432,17 @@ SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0, { SCM res = SCM_EOL; - if (IS_BITVECTOR (vec)) + VALIDATE_BITVECTOR (1, vec); + + const uint32_t *bits = BITVECTOR_BITS (vec); + size_t len = BITVECTOR_LENGTH (vec); + size_t word_len = (len + 31) / 32; + + for (size_t i = 0; i < word_len; i++, len -= 32) { - const uint32_t *bits = BITVECTOR_BITS (vec); - size_t len = BITVECTOR_LENGTH (vec); - size_t word_len = (len + 31) / 32; - - for (size_t i = 0; i < word_len; i++, len -= 32) - { - uint32_t mask = 1; - for (size_t j = 0; j < 32 && j < len; j++, mask <<= 1) - res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res); - } - } - else - { - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - - scm_bitvector_elements (vec, &handle, &off, &len, &inc); - - scm_c_issue_deprecation_warning - ("Using bitvector->list on arrays is deprecated. " - "Use array->list instead."); - - for (size_t i = 0; i < len; i++) - res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); - - scm_array_handle_release (&handle); - + uint32_t mask = 1; + for (size_t j = 0; j < 32 && j < len; j++, mask <<= 1) + res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res); } return scm_reverse_x (res, SCM_EOL); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 0df946482..7329e3b5e 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1,4 +1,4 @@ -/* Copyright 2003-2004,2006,2008-2018,2020,2021,2022 +/* Copyright 2003-2004,2006,2008-2018,2020,2021,2022,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -21,816 +21,15 @@ # include #endif -#include -#include -#include - #define SCM_BUILDING_DEPRECATED_CODE -#include "alist.h" -#include "array-handle.h" -#include "arrays.h" -#include "boolean.h" -#include "bitvectors.h" -#include "deprecation.h" -#include "dynl.h" -#include "eval.h" -#include "foreign.h" -#include "finalizers.h" -#include "generalized-vectors.h" -#include "gc.h" -#include "gsubr.h" -#include "modules.h" -#include "objprop.h" -#include "procprop.h" -#include "srcprop.h" -#include "srfi-4.h" -#include "strings.h" -#include "symbols.h" -#include "uniform.h" -#include "vectors.h" - #include "deprecated.h" #if (SCM_ENABLE_DEPRECATED == 1) -#ifndef MAXPATHLEN -#define MAXPATHLEN 80 -#endif /* ndef MAXPATHLEN */ -#ifndef X_OK -#define X_OK 1 -#endif /* ndef X_OK */ - -char * -scm_find_executable (const char *name) -{ - char tbuf[MAXPATHLEN]; - int i = 0, c; - FILE *f; - - scm_c_issue_deprecation_warning ("scm_find_executable is deprecated."); - - /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */ - if (access (name, X_OK)) - return 0L; - f = fopen (name, "r"); - if (!f) - return 0L; - if ((fgetc (f) == '#') && (fgetc (f) == '!')) - { - while (1) - switch (c = fgetc (f)) - { - case /*WHITE_SPACES */ ' ': - case '\t': - case '\r': - case '\f': - case EOF: - tbuf[i] = 0; - fclose (f); - return strdup (tbuf); - default: - tbuf[i++] = c; - break; - } - } - fclose (f); - return strdup (name); -} - - - - -int -scm_is_simple_vector (SCM obj) -{ - scm_c_issue_deprecation_warning - ("scm_is_simple_vector is deprecated. Use scm_is_vector instead."); - return SCM_I_IS_VECTOR (obj); -} - -SCM -scm_bitvector_p (SCM vec) -{ - scm_c_issue_deprecation_warning - ("scm_bitvector_p is deprecated. Use scm_is_bitvector instead."); - - return scm_from_bool (scm_is_bitvector (vec)); -} - -SCM -scm_bitvector (SCM list) -{ - scm_c_issue_deprecation_warning - ("scm_bitvector is deprecated. Use scm_list_to_bitvector instead."); - - return scm_list_to_bitvector (list); -} - -SCM -scm_make_bitvector (SCM len, SCM fill) -{ - scm_c_issue_deprecation_warning - ("scm_make_bitvector is deprecated. Use scm_c_make_bitvector instead."); - - return scm_c_make_bitvector (scm_to_size_t (len), fill); -} - -SCM -scm_bitvector_length (SCM vec) -{ - scm_c_issue_deprecation_warning - ("scm_bitvector_length is deprecated. Use scm_c_bitvector_length " - "instead."); - - return scm_from_size_t (scm_c_bitvector_length (vec)); -} - -SCM -scm_c_bitvector_ref (SCM vec, size_t idx) -{ - scm_c_issue_deprecation_warning - ("bitvector-ref is deprecated. Use bitvector-bit-set? instead."); - - if (scm_is_bitvector (vec)) - return scm_from_bool (scm_c_bitvector_bit_is_set (vec, idx)); - - SCM res; - scm_t_array_handle handle; - size_t len, off; - ssize_t inc; - - const uint32_t *bits = - scm_bitvector_elements (vec, &handle, &off, &len, &inc); - - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - res = scm_from_bool (bits[idx/32] & (1L << (idx%32))); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0, - (SCM vec, SCM idx), - "Return the element at index @var{idx} of the bitvector\n" - "@var{vec}.") -#define FUNC_NAME s_scm_bitvector_ref -{ - return scm_c_bitvector_ref (vec, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) -{ - scm_c_issue_deprecation_warning - ("bitvector-set! is deprecated. Use bitvector-set-bit! or " - "bitvector-clear-bit! instead."); - - if (scm_is_bitvector (vec)) - { - if (scm_is_true (val)) - scm_c_bitvector_set_bit_x (vec, idx); - else - scm_c_bitvector_clear_bit_x (vec, idx); - } - else - { - scm_t_array_handle handle; - uint32_t *bits, mask; - size_t len, off; - ssize_t inc; - - bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - - mask = 1L << (idx%32); - if (scm_is_true (val)) - bits[idx/32] |= mask; - else - bits[idx/32] &= ~mask; - - scm_array_handle_release (&handle); - } -} - -SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0, - (SCM vec, SCM idx, SCM val), - "Set the element at index @var{idx} of the bitvector\n" - "@var{vec} when @var{val} is true, else clear it.") -#define FUNC_NAME s_scm_bitvector_set_x -{ - scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0, - (SCM vec, SCM val), - "Set all elements of the bitvector\n" - "@var{vec} when @var{val} is true, else clear them.") -#define FUNC_NAME s_scm_bitvector_fill_x -{ - scm_c_issue_deprecation_warning - ("bitvector-fill! is deprecated. Use bitvector-set-all-bits! or " - "bitvector-clear-all-bits! instead."); - - if (scm_is_bitvector (vec)) - { - if (scm_is_true (val)) - scm_c_bitvector_set_all_bits_x (vec); - else - scm_c_bitvector_clear_all_bits_x (vec); - - return SCM_UNSPECIFIED; - } - - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - - scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc); - - size_t i; - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, val); - - scm_array_handle_release (&handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, - (SCM v), - "Modify the bit vector @var{v} by replacing each element with\n" - "its negation.") -#define FUNC_NAME s_scm_bit_invert_x -{ - scm_c_issue_deprecation_warning - ("bit-invert! is deprecated. Use bitvector-flip-all-bits!, or " - "scalar array accessors in a loop for generic arrays."); - - if (scm_is_bitvector (v)) - scm_c_bitvector_flip_all_bits_x (v); - else - { - size_t off, len; - ssize_t inc; - scm_t_array_handle handle; - - scm_bitvector_writable_elements (v, &handle, &off, &len, &inc); - for (size_t i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, - scm_not (scm_array_handle_ref (&handle, i*inc))); - scm_array_handle_release (&handle); - } - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, - (SCM b, SCM bitvector), - "Return the number of occurrences of the boolean @var{b} in\n" - "@var{bitvector}.") -#define FUNC_NAME s_scm_bit_count -{ - int bit = scm_to_bool (b); - size_t count = 0, len; - - scm_c_issue_deprecation_warning - ("bit-count is deprecated. Use bitvector-count, or a loop over array-ref " - "if array support is needed."); - - if (scm_is_bitvector (bitvector)) - { - len = scm_to_size_t (scm_bitvector_length (bitvector)); - count = scm_c_bitvector_count (bitvector); - } - else - { - scm_t_array_handle handle; - size_t off; - ssize_t inc; - - scm_bitvector_elements (bitvector, &handle, &off, &len, &inc); - - for (size_t i = 0; i < len; i++) - if (scm_is_true (scm_array_handle_ref (&handle, i*inc))) - count++; - - scm_array_handle_release (&handle); - } - - return scm_from_size_t (bit ? count : len-count); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Return a count of how many entries in bit vector @var{v} are\n" - "equal to @var{obj}, with @var{kv} selecting the entries to\n" - "consider.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are considered.\n" - "@var{kv} and @var{v} must be the same length.\n" - "\n" - "If @var{kv} is a u32vector, then it contains\n" - "the indexes in @var{v} to consider.\n" - "\n" - "For example,\n" - "\n" - "@example\n" - "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" - "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n" - "@end example") -#define FUNC_NAME s_scm_bit_count_star -{ - size_t count = 0; - - scm_c_issue_deprecation_warning - ("bit-count* is deprecated. Use bitvector-count-bits instead, and in the " - "case of counting false bits, subtract from a bitvector-count on the " - "selection bitvector."); - - /* Validate that OBJ is a boolean so this is done even if we don't - need BIT. - */ - int bit = scm_to_bool (obj); - - if (scm_is_bitvector (v) && scm_is_bitvector (kv)) - { - count = scm_c_bitvector_count_bits (v, kv); - if (bit == 0) - count = scm_c_bitvector_count (kv) - count; - } - else - { - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - - scm_bitvector_elements (v, &v_handle, &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - size_t kv_len = scm_c_bitvector_length (kv); - for (size_t i = 0; i < kv_len; i++) - if (scm_c_bitvector_bit_is_set (kv, i)) - { - SCM elt = scm_array_handle_ref (&v_handle, i*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t i, kv_len; - ssize_t kv_inc; - const uint32_t *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - - for (i = 0; i < kv_len; i++, kv_elts += kv_inc) - { - SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - } - - return scm_from_size_t (count); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, - (SCM item, SCM v, SCM k), - "Return the index of the first occurrence of @var{item} in bit\n" - "vector @var{v}, starting from @var{k}. If there is no\n" - "@var{item} entry between @var{k} and the end of\n" - "@var{v}, then return @code{#f}. For example,\n" - "\n" - "@example\n" - "(bit-position #t #*000101 0) @result{} 3\n" - "(bit-position #f #*0001111 3) @result{} #f\n" - "@end example") -#define FUNC_NAME s_scm_bit_position -{ - scm_c_issue_deprecation_warning - ("bit-position is deprecated. Use bitvector-position, or " - "array-ref in a loop if you need generic arrays instead."); - - if (scm_is_bitvector (v)) - return scm_bitvector_position (v, item, k); - - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_bitvector_elements (v, &handle, &off, &len, &inc); - int bit = scm_to_bool (item); - size_t first_bit = scm_to_unsigned_integer (k, 0, len); - SCM res = SCM_BOOL_F; - for (size_t i = first_bit; i < len; i++) - { - SCM elt = scm_array_handle_ref (&handle, i*inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - { - res = scm_from_size_t (i); - break; - } - } - scm_array_handle_release (&handle); - - return res; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n" - "selecting the entries to change. The return value is\n" - "unspecified.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" - "@var{v} must be at least as long as @var{kv}. When @var{obj}\n" - "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" - "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #*10010001 #t)\n" - "bv\n" - "@result{} #*11010011\n" - "@end example\n" - "\n" - "If @var{kv} is a u32vector, then its elements are\n" - "indices into @var{v} which are set to @var{obj}.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #u32(5 2 7) #t)\n" - "bv\n" - "@result{} #*01100111\n" - "@end example") -#define FUNC_NAME s_scm_bit_set_star_x -{ - scm_c_issue_deprecation_warning - ("bit-set*! is deprecated. Use bitvector-set-bits! or " - "bitvector-clear-bits! on bitvectors, or array-set! in a loop " - "if you need to work on generic arrays."); - - int bit = scm_to_bool (obj); - if (scm_is_bitvector (v) && scm_is_bitvector (kv)) - { - if (bit) - scm_c_bitvector_set_bits_x (v, kv); - else - scm_c_bitvector_clear_bits_x (v, kv); - - return SCM_UNSPECIFIED; - } - - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - scm_bitvector_writable_elements (v, &v_handle, &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - size_t kv_len = scm_c_bitvector_length (kv); - - if (v_len < kv_len) - scm_misc_error (NULL, - "selection bitvector longer than target bitvector", - SCM_EOL); - - for (size_t i = 0; i < kv_len; i++) - if (scm_is_true (scm_c_bitvector_ref (kv, i))) - scm_array_handle_set (&v_handle, i*v_inc, obj); - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t kv_len; - ssize_t kv_inc; - const uint32_t *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - for (size_t i = 0; i < kv_len; i++, kv_elts += kv_inc) - scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj); - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM -scm_istr2bve (SCM str) -{ - scm_t_array_handle handle; - size_t len = scm_i_string_length (str); - SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED); - SCM res = vec; - - uint32_t mask; - size_t k, j; - const char *c_str; - uint32_t *data; - - scm_c_issue_deprecation_warning - ("scm_istr2bve is deprecated. " - "Read from a string instead, prefixed with `#*'."); - - data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL); - c_str = scm_i_string_chars (str); - - for (k = 0; k < (len + 31) / 32; k++) - { - data[k] = 0L; - j = len - k * 32; - if (j > 32) - j = 32; - for (mask = 1L; j--; mask <<= 1) - switch (*c_str++) - { - case '0': - break; - case '1': - data[k] |= mask; - break; - default: - res = SCM_BOOL_F; - goto exit; - } - } - - exit: - scm_array_handle_release (&handle); - scm_remember_upto_here_1 (str); - return res; -} - -SCM -scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, - size_t byte_len) -#define FUNC_NAME "scm_from_contiguous_typed_array" -{ - size_t k, rlen = 1; - scm_t_array_dim *s; - SCM ra; - scm_t_array_handle h; - void *elts; - size_t sz; - - scm_c_issue_deprecation_warning - ("scm_from_contiguous_typed_array is deprecated. " - "Instead, use scm_make_typed_array() and the array handle functions " - "to copy data to the new array."); - - ra = scm_i_shap2ra (bounds); - s = SCM_I_ARRAY_DIMS (ra); - k = SCM_I_ARRAY_NDIM (ra); - - while (k--) - { - s[k].inc = rlen; - SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - } - SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED)); - - - scm_array_get_handle (ra, &h); - elts = h.writable_elements; - sz = scm_array_handle_uniform_element_bit_size (&h); - scm_array_handle_release (&h); - - if (sz >= 8 && ((sz % 8) == 0)) - { - if (byte_len % (sz / 8)) - SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); - if (byte_len / (sz / 8) != rlen) - SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); - } - else if (sz < 8) - { - /* Elements of sub-byte size (bitvectors) are addressed in 32-bit - units. */ - if (byte_len != ((rlen * sz + 31) / 32) * 4) - SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); - } - else - /* an internal guile error, really */ - SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL); - - memcpy (elts, bytes, byte_len); - - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (0 == s->lbnd) - return SCM_I_ARRAY_V (ra); - return ra; -} -#undef FUNC_NAME - - -SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy"); - -SCM -scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) -{ - scm_c_issue_deprecation_warning - ("scm_make_srcprops is deprecated; use set-source-properties! instead"); - - alist = SCM_UNBNDP (copy) ? alist : scm_acons (scm_sym_copy, copy, alist); - return scm_i_make_srcprops (scm_from_long (line), scm_from_int (col), - filename, alist); -} - -SCM -scm_copy_tree (SCM obj) -{ - scm_c_issue_deprecation_warning - ("scm_copy_tree is deprecated; use copy-tree from (ice-9 copy-tree) " - "instead."); - - return scm_call_1 (scm_c_public_ref ("ice-9 copy-tree", "copy-tree"), obj); -} - - -/* Symbol properties. */ - -SCM_SYMBOL (symbol_function_slot, "symbol-function-slot"); -SCM_SYMBOL (symbol_property_slot, "symbol-property-slot"); - -SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0, - (SCM s), - "Return the contents of the symbol @var{s}'s @dfn{function slot}.") -#define FUNC_NAME s_scm_symbol_fref -{ - SCM_VALIDATE_SYMBOL (1, s); - return scm_object_property (s, symbol_function_slot); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0, - (SCM s), - "Return the @dfn{property list} currently associated with the\n" - "symbol @var{s}.") -#define FUNC_NAME s_scm_symbol_pref -{ - SCM result; - - SCM_VALIDATE_SYMBOL (1, s); - result = scm_object_property (s, symbol_property_slot); - return scm_is_false (result) ? SCM_EOL : result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, - (SCM s, SCM val), - "Change the binding of the symbol @var{s}'s function slot.") -#define FUNC_NAME s_scm_symbol_fset_x -{ - SCM_VALIDATE_SYMBOL (1, s); - return scm_set_object_property_x (s, symbol_function_slot, val); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, - (SCM s, SCM val), - "Change the binding of the symbol @var{s}'s property slot.") -#define FUNC_NAME s_scm_symbol_pset_x -{ - SCM_VALIDATE_SYMBOL (1, s); - return scm_set_object_property_x (s, symbol_property_slot, val); -} -#undef FUNC_NAME - - - -SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, (SCM obj), "") -#define FUNC_NAME s_scm_dynamic_unlink -{ - scm_c_issue_deprecation_warning - ("scm_dynamic_unlink has no effect and is deprecated. Unloading " - "shared libraries is no longer supported."); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - - - -static void -finalize_bignum (void *ptr, void *data) -{ - SCM bignum; - - bignum = SCM_PACK_POINTER (ptr); - mpz_clear (SCM_I_BIG_MPZ (bignum)); -} - -static SCM -make_bignum (void) -{ - scm_t_bits *p; - - /* Allocate one word for the type tag and enough room for an `mpz_t'. */ - p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t), - "bignum"); - p[0] = scm_tc16_big; - scm_i_set_finalizer (p, finalize_bignum, NULL); - - return SCM_PACK (p); -} - -/* scm_i_big2dbl() rounds to the closest representable double, - in accordance with R5RS exact->inexact. */ -double -scm_i_big2dbl (SCM b) -{ - scm_c_issue_deprecation_warning - ("scm_i_big2dbl is deprecated. Use scm_to_double instead."); - return scm_to_double (b); -} - -SCM -scm_i_long2big (long x) -{ - scm_c_issue_deprecation_warning - ("scm_i_long2big is deprecated. Use scm_from_long instead."); - /* Return a newly created bignum initialized to X. */ - SCM z = make_bignum (); - mpz_init_set_si (SCM_I_BIG_MPZ (z), x); - return z; -} - -SCM -scm_i_ulong2big (unsigned long x) -{ - scm_c_issue_deprecation_warning - ("scm_i_ulong2big is deprecated. Use scm_from_ulong instead."); - /* Return a newly created bignum initialized to X. */ - SCM z = make_bignum (); - mpz_init_set_ui (SCM_I_BIG_MPZ (z), x); - return z; -} - -SCM -scm_i_clonebig (SCM src_big, int same_sign_p) -{ - scm_c_issue_deprecation_warning - ("scm_i_clonebig is deprecated. Use scm_to_mpz/scm_from_mpz instead."); - /* Copy src_big's value, negate it if same_sign_p is false, and return. */ - SCM z = make_bignum (); - scm_to_mpz (src_big, SCM_I_BIG_MPZ (z)); - if (!same_sign_p) - mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); - return z; -} - -SCM -scm_i_normbig (SCM b) -{ - scm_c_issue_deprecation_warning - ("scm_i_normbig is deprecated. Direct bignum bit manipulation is not " - "supported."); - /* convert a big back to a fixnum if it'll fit */ - /* presume b is a bignum */ - if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b))) - { - scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b)); - if (SCM_FIXABLE (val)) - b = SCM_I_MAKINUM (val); - } - return b; -} - -int scm_install_gmp_memory_functions; +/* Deprecated functions go here. */ @@ -840,4 +39,4 @@ scm_i_init_deprecated () #include "deprecated.x" } -#endif /* SCM_ENABLE_DEPRECATD == 1 */ +#endif /* SCM_ENABLE_DEPRECATED == 1 */ diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 75a6e78e1..f1a76baa2 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -1,7 +1,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright 2003-2007,2009-2018,2020-2022 +/* Copyright 2003-2007,2009-2018,2020-2022,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -26,149 +26,6 @@ /* Deprecated declarations go here. */ -/* Return true (non-zero) if GCC version MAJ.MIN or later is being used - * (macro taken from glibc.) */ -#if defined __GNUC__ && defined __GNUC_MINOR__ -# define SCM_GNUC_PREREQ(maj, min) \ - ((__GNUC__ << 16) + __GNUC_MINOR__ >= ((maj) << 16) + (min)) -#else -# define SCM_GNUC_PREREQ(maj, min) 0 -#endif - -#define scm_i_jmp_buf scm_i_jmp_buf_GONE__USE_JMP_BUF_INSTEAD - -#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \ - do { \ - SCM_ASSERT (scm_is_vector (v) || scm_is_true (scm_f64vector_p (v)), \ - v, pos, FUNC_NAME); \ - } while (0) - -#ifdef SCM_SUPPORT_STATIC_ALLOCATION -#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \ - static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \ - c_name ## _raw_cell [2] = \ - { \ - { SCM_PACK (car), SCM_PACK (cbr) }, \ - { SCM_PACK (ccr), SCM_PACK (cdr) } \ - }; \ - static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell) -#endif /* SCM_SUPPORT_STATIC_ALLOCATION */ - -#define scm_gc_running_p 0 - -#define SCM_I_UTYPE_MAX(type) ((type)-1) -#define SCM_I_TYPE_MAX(type,umax) ((type)((umax)/2)) -#define SCM_I_TYPE_MIN(type,umax) (-((type)((umax)/2))-1) - -#define SCM_T_UINT8_MAX UINT8_MAX -#define SCM_T_INT8_MIN INT8_MIN -#define SCM_T_INT8_MAX INT8_MAX - -#define SCM_T_UINT16_MAX UINT16_MAX -#define SCM_T_INT16_MIN INT16_MIN -#define SCM_T_INT16_MAX INT16_MAX - -#define SCM_T_UINT32_MAX UINT32_MAX -#define SCM_T_INT32_MIN INT32_MIN -#define SCM_T_INT32_MAX INT32_MAX - -#define SCM_T_UINT64_MAX UINT64_MAX -#define SCM_T_INT64_MIN INT64_MIN -#define SCM_T_INT64_MAX INT64_MAX - -#define SCM_T_UINTMAX_MAX UINTMAX_MAX -#define SCM_T_INTMAX_MIN INTMAX_MIN -#define SCM_T_INTMAX_MAX INTMAX_MAX - -#define SCM_T_UINTPTR_MAX UINTPTR_MAX -#define SCM_T_INTPTR_MIN INTPTR_MIN -#define SCM_T_INTPTR_MAX INTPTR_MAX - -#define SCM_HAVE_T_INT64 1 /* 0 or 1 */ -#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */ - -#define SCM_HAVE_ARRAYS 1 /* always true now */ - -#ifdef __GNUC__ -#define SCM_DEPRECATED_TYPE __attribute__((__deprecated__)) -#else -#define SCM_DEPRECATED_TYPE /*deprecated*/ -#endif -typedef int8_t scm_t_int8 SCM_DEPRECATED_TYPE; -typedef uint8_t scm_t_uint8 SCM_DEPRECATED_TYPE; -typedef int16_t scm_t_int16 SCM_DEPRECATED_TYPE; -typedef uint16_t scm_t_uint16 SCM_DEPRECATED_TYPE; -typedef int32_t scm_t_int32 SCM_DEPRECATED_TYPE; -typedef uint32_t scm_t_uint32 SCM_DEPRECATED_TYPE; -typedef intmax_t scm_t_intmax SCM_DEPRECATED_TYPE; -typedef uintmax_t scm_t_uintmax SCM_DEPRECATED_TYPE; -typedef intptr_t scm_t_intptr SCM_DEPRECATED_TYPE; -typedef uintptr_t scm_t_uintptr SCM_DEPRECATED_TYPE; -typedef int64_t scm_t_int64 SCM_DEPRECATED_TYPE; -typedef uint64_t scm_t_uint64 SCM_DEPRECATED_TYPE; -typedef ptrdiff_t scm_t_ptrdiff SCM_DEPRECATED_TYPE; - -typedef struct scm_thread scm_i_thread SCM_DEPRECATED_TYPE; -#undef SCM_DEPRECATED_TYPE - -#define SCM_MEMORY_ERROR do { scm_report_out_of_memory (); } while (0) - -SCM_DEPRECATED char* scm_find_executable (const char *name); - -SCM_DEPRECATED int scm_is_simple_vector (SCM obj); -SCM_DEPRECATED SCM scm_bitvector_p (SCM vec); -SCM_DEPRECATED SCM scm_bitvector (SCM bits); -SCM_DEPRECATED SCM scm_make_bitvector (SCM len, SCM fill); -SCM_DEPRECATED SCM scm_bitvector_length (SCM vec); -SCM_DEPRECATED SCM scm_c_bitvector_ref (SCM vec, size_t idx); -SCM_DEPRECATED SCM scm_bitvector_ref (SCM vec, SCM idx); -SCM_DEPRECATED void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val); -SCM_DEPRECATED SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val); -SCM_DEPRECATED SCM scm_bitvector_fill_x (SCM vec, SCM val); -SCM_DEPRECATED SCM scm_bit_invert_x (SCM vec); -SCM_DEPRECATED SCM scm_bit_count (SCM item, SCM seq); -SCM_DEPRECATED SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); -SCM_DEPRECATED SCM scm_bit_position (SCM item, SCM v, SCM k); -SCM_DEPRECATED SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); -SCM_DEPRECATED SCM scm_istr2bve (SCM str); -SCM_DEPRECATED SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, - const void *bytes, - size_t byte_len); - -#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1 - -SCM_DEPRECATED scm_t_bits scm_tc16_srcprops; -SCM_DEPRECATED SCM scm_sym_copy; -SCM_DEPRECATED SCM scm_make_srcprops (long line, int col, SCM filename, - SCM copy, SCM alist); - -SCM_DEPRECATED SCM scm_copy_tree (SCM obj); - -#define SCM_SYMBOL_FUNC(x) (scm_symbol_fref (x)) -#define SCM_SET_SYMBOL_FUNC(x,f) (scm_symbol_fset_x (x, f)) -#define SCM_SYMBOL_PROPS(x) (scm_symbol_pref (x)) -#define SCM_SET_SYMBOL_PROPS(x,p) (scm_symbol_pset_x (x, p)) - -SCM_DEPRECATED SCM scm_symbol_fref (SCM s); -SCM_DEPRECATED SCM scm_symbol_pref (SCM s); -SCM_DEPRECATED SCM scm_symbol_fset_x (SCM s, SCM val); -SCM_DEPRECATED SCM scm_symbol_pset_x (SCM s, SCM val); - -SCM_DEPRECATED SCM scm_dynamic_unlink (SCM obj); - -/* Each bignum is just an mpz_t stored in a double cell starting at word 1. */ -#if defined BUILDING_LIBGUILE || SCM_ENABLE_MINI_GMP == 0 -#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1)))) -#endif - -SCM_DEPRECATED int scm_install_gmp_memory_functions; -SCM_DEPRECATED SCM scm_i_normbig (SCM x); -SCM_DEPRECATED double scm_i_big2dbl (SCM b); -SCM_DEPRECATED SCM scm_i_long2big (long n); -SCM_DEPRECATED SCM scm_i_ulong2big (unsigned long n); -SCM_DEPRECATED SCM scm_i_clonebig (SCM src_big, int same_sign_p); - - void scm_i_init_deprecated (void); #endif diff --git a/libguile/posix.c b/libguile/posix.c index c8bbb0f83..5a4739e42 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -82,10 +82,6 @@ #include "verify.h" #include "version.h" -#if (SCM_ENABLE_DEPRECATED == 1) -#include "deprecation.h" -#endif - #include "posix.h" #if HAVE_SYS_WAIT_H @@ -1778,37 +1774,6 @@ SCM_DEFINE (scm_environ, "environ", 0, 1, 0, } #undef FUNC_NAME -#if (SCM_ENABLE_DEPRECATED == 1) -#ifdef ENABLE_TMPNAM -#ifdef L_tmpnam - -SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0, - (), - "Return a name in the file system that does not match any\n" - "existing file. However there is no guarantee that another\n" - "process will not create the file after @code{tmpnam} is called.\n" - "Care should be taken if opening the file, e.g., use the\n" - "@code{O_EXCL} open flag or use @code{mkstemp} instead.") -#define FUNC_NAME s_scm_tmpnam -{ - char name[L_tmpnam]; - char *rv; - - scm_c_issue_deprecation_warning - ("Use of tmpnam is deprecated. Use mkstemp instead."); - - SCM_SYSCALL (rv = tmpnam (name)); - if (rv == NULL) - /* not SCM_SYSERROR since errno probably not set. */ - SCM_MISC_ERROR ("tmpnam failed", SCM_EOL); - return scm_from_locale_string (name); -} -#undef FUNC_NAME - -#endif -#endif -#endif - SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0, (void), "Return an input/output port to a unique temporary file\n" diff --git a/libguile/posix.h b/libguile/posix.h index a4b0297b3..39c67bd4e 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -1,7 +1,7 @@ #ifndef SCM_POSIX_H #define SCM_POSIX_H -/* Copyright 1995-1998, 2000-2001, 2003, 2006, 2008-2011, 2018, 2021-2023 +/* Copyright 1995-1998, 2000-2001, 2003, 2006, 2008-2011, 2018, 2021-2023, 2025 Free Software Foundation, Inc. This file is part of Guile. @@ -65,7 +65,6 @@ SCM_API SCM scm_execle (SCM filename, SCM env, SCM args); SCM_API SCM scm_fork (void); SCM_API SCM scm_uname (void); SCM_API SCM scm_environ (SCM env); -SCM_API SCM scm_tmpnam (void); SCM_API SCM scm_tmpfile (void); SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes); SCM_API SCM scm_close_pipe (SCM port); diff --git a/libguile/struct.c b/libguile/struct.c index 8721c5469..3e220d9d0 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -181,12 +181,6 @@ scm_is_valid_vtable_layout (SCM layout) case 'w': case 'h': break; - case 'r': - scm_c_issue_deprecation_warning - ("Read-only struct fields are deprecated. Implement access " - "control at a higher level instead, as structs no longer " - "enforce field permissions."); - break; default: return 0; } diff --git a/libguile/vectors.c b/libguile/vectors.c index 18c7dc54d..d81dc61a7 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1996,1998-2001,2006,2008-2012,2014,2018-2020 +/* Copyright 1995-1996,1998-2001,2006,2008-2012,2014,2018-2020,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -268,51 +268,27 @@ SCM_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0, #define FUNC_NAME s_scm_vector_copy_partial { SCM result; - if (SCM_I_IS_VECTOR (vec)) - { - size_t cstart = 0, cend = SCM_I_VECTOR_LENGTH (vec); + + SCM_VALIDATE_VECTOR (1, 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 + if (!SCM_UNBNDP (start)) { - scm_t_array_handle handle; - size_t i, len; - ssize_t inc; - const SCM *src; - SCM *dst; + cstart = scm_to_size_t (start); + SCM_ASSERT_RANGE (SCM_ARG2, start, cstart<=cend); - 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); + 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)); return result; } #undef FUNC_NAME @@ -377,32 +353,13 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, { SCM res = SCM_EOL; - 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; + SCM_VALIDATE_VECTOR (1, vec); - data = scm_vector_elements (vec, &handle, &len, &inc); - scm_c_issue_deprecation_warning - ("Using vector->list on arrays is deprecated. " - "Use array->list instead."); + 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); - 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 @@ -468,53 +425,24 @@ 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 { - 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); + SCM_VALIDATE_VECTOR (1, vec1); + SCM_VALIDATE_VECTOR (4, 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; + 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); - 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."); + 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]; - 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 @@ -530,64 +458,28 @@ 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 { - if (SCM_I_IS_VECTOR (vec1) && SCM_I_IS_VECTOR (vec2)) + SCM_VALIDATE_VECTOR (1, vec1); + SCM_VALIDATE_VECTOR (4, 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)); + j += (e - i); + + while (i < 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); + --e; + --j; + elts2[j] = elts1[e]; } return SCM_UNSPECIFIED; diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test index 371b51840..a8dc34cef 100644 --- a/test-suite/tests/vectors.test +++ b/test-suite/tests/vectors.test @@ -1,6 +1,6 @@ ;;;; vectors.test --- test suite for Guile's vector functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2006, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 2010, 2011, 2025 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -50,11 +50,7 @@ (pass-if "string-vector 2" (equal? '("abc\u0100" "def\u0101" "ghi\u0102") - (vector->list #("abc\u0100" "def\u0101" "ghi\u0102")))) - - (pass-if "shared array" - (let ((b (make-shared-array #(1) (lambda (x) '(0)) 2))) - (equal? b (list->vector (vector->list b)))))) + (vector->list #("abc\u0100" "def\u0101" "ghi\u0102"))))) (with-test-prefix "make-vector"