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

All literal constants are read-only

Browse source 
* libguile/array-handle.c (initialize_vector_handle): Add mutable_p
  argument.  Unless the vector handle is mutable, null out its
  writable_elements member.
  (scm_array_get_handle): Adapt to determine mutability of the various
  arrays.
  (scm_array_handle_elements, scm_array_handle_writable_elements):
  Reverse the sense: instead of implementing read-only in terms of
  read-write, go the other way around, adding an assertion in the
  read-write case that the array handle is mutable.
* libguile/array-map.c (racp): Assert that the destination is mutable.
* libguile/bitvectors.c (SCM_F_BITVECTOR_IMMUTABLE, IS_BITVECTOR):
  (IS_MUTABLE_BITVECTOR): Add a flag to indicate immutability.
  (scm_i_bitvector_bits): Fix indentation.
  (scm_i_is_mutable_bitvector): New helper.
  (scm_array_handle_bit_elements)
  ((scm_array_handle_bit_writable_elements): Build writable_elements in
  terms of elements.
  (scm_bitvector_elements, scm_bitvector_writable_elements): Likewise.
  (scm_c_bitvector_set_x): Require a mutable bitvector for the
  fast-path.
  (scm_bitvector_to_list, scm_bit_count): Use read-only elements()
  function.
* libguile/bitvectors.h (scm_i_is_mutable_bitvector): New decl.
* libguile/bytevectors.c (INTEGER_ACCESSOR_PROLOGUE):
  (INTEGER_GETTER_PROLOGUE, INTEGER_SETTER_PROLOGUE):
  (INTEGER_REF, INTEGER_NATIVE_REF, INTEGER_SET, INTEGER_NATIVE_SET):
  (GENERIC_INTEGER_ACCESSOR_PROLOGUE):
  (GENERIC_INTEGER_GETTER_PROLOGUE, GENERIC_INTEGER_SETTER_PROLOGUE):
  (LARGE_INTEGER_NATIVE_REF, LARGE_INTEGER_NATIVE_SET):
  (IEEE754_GETTER_PROLOGUE, IEEE754_SETTER_PROLOGUE):
  (IEEE754_REF, IEEE754_NATIVE_REF, IEEE754_SET, IEEE754_NATIVE_SET):
  Setters require a mutable bytevector.
  (SCM_BYTEVECTOR_SET_FLAG): New helper.
  (SCM_BYTEVECTOR_SET_CONTIGUOUS_P, SCM_BYTEVECTOR_SET_ELEMENT_TYPE):
  Remove helpers.
  (SCM_VALIDATE_MUTABLE_BYTEVECTOR): New helper.
  (make_bytevector, make_bytevector_from_buffer): Use
  SCM_SET_BYTEVECTOR_FLAGS.
  (scm_c_bytevector_set_x, scm_bytevector_fill_x)
  (scm_bytevector_copy_x): Require a mutable bytevector.
* libguile/bytevectors.h (SCM_F_BYTEVECTOR_CONTIGUOUS)
  (SCM_F_BYTEVECTOR_IMMUTABLE, SCM_MUTABLE_BYTEVECTOR_P): New
  definitions.
* libguile/bytevectors.h (SCM_BYTEVECTOR_CONTIGUOUS_P): Just access one
  bit.
* libguile/srfi-4.c (DEFINE_SRFI_4_C_FUNCS): Implement
  writable_elements() in terms of elements().
* libguile/strings.c (scm_i_string_is_mutable): New helper.
* libguile/uniform.c (scm_array_handle_uniform_elements):
  (scm_array_handle_uniform_writable_elements): Implement
  writable_elements in terms of elements.
* libguile/vectors.c (SCM_VALIDATE_MUTABLE_VECTOR): New helper.
  (scm_vector_elements, scm_vector_writable_elements): Implement
  writable_elements in terms of elements.
  (scm_c_vector_set_x): Require a mutable vector.
* libguile/vectors.h (SCM_F_VECTOR_IMMUTABLE, SCM_I_IS_MUTABLE_VECTOR):
  New definitions.
* libguile/vm-engine.c (VM_VALIDATE_MUTABLE_BYTEVECTOR):
  (VM_VALIDATE_MUTABLE_VECTOR, vector-set!, vector-set!/immediate)
  (BV_BOUNDED_SET, BV_SET): Require mutable bytevector/vector.
* libguile/vm.c (vm_error_not_a_mutable_bytevector):
  (vm_error_not_a_mutable_vector): New definitions.
* module/system/vm/assembler.scm (link-data): Mark residualized vectors,
  bytevectors, and bitvectors as being read-only.
This commit is contained in:
Andy Wingo 2017-04-18 14:56:48 +02:00
parent 6e573a0885
commit 7ed54fd36d
15 changed files with 237 additions and 131 deletions
Download patch file Download diff file Expand all files Collapse all files

29
libguile/array-handle.c
View file

@ -140,7 +140,7 @@ static void
initialize_vector_handle (scm_t_array_handle *h, size_t len, initialize_vector_handle (scm_t_array_handle *h, size_t len,
scm_t_array_element_type element_type, scm_t_array_element_type element_type,
scm_t_vector_ref vref, scm_t_vector_set vset, scm_t_vector_ref vref, scm_t_vector_set vset,
void *writable_elements) const void *elements, int mutable_p)
{ {
h->base = 0; h->base = 0;
h->ndims = 1; h->ndims = 1;
@ -149,7 +149,8 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len,
h->dim0.ubnd = (ssize_t) (len - 1U); h->dim0.ubnd = (ssize_t) (len - 1U);
h->dim0.inc = 1; h->dim0.inc = 1;
h->element_type = element_type; h->element_type = element_type;
h->elements = h->writable_elements = writable_elements; h->elements = elements;
h->writable_elements = mutable_p ? ((void *) elements) : NULL;
h->vector = h->array; h->vector = h->array;
h->vref = vref; h->vref = vref;
h->vset = vset; h->vset = vset;
@ -169,19 +170,22 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
initialize_vector_handle (h, scm_c_string_length (array), initialize_vector_handle (h, scm_c_string_length (array),
SCM_ARRAY_ELEMENT_TYPE_CHAR, SCM_ARRAY_ELEMENT_TYPE_CHAR,
scm_c_string_ref, scm_c_string_set_x, scm_c_string_ref, scm_c_string_set_x,
NULL); NULL,
scm_i_string_is_mutable (array));
break; break;
case scm_tc7_vector: case scm_tc7_vector:
initialize_vector_handle (h, scm_c_vector_length (array), initialize_vector_handle (h, scm_c_vector_length (array),
SCM_ARRAY_ELEMENT_TYPE_SCM, SCM_ARRAY_ELEMENT_TYPE_SCM,
scm_c_vector_ref, scm_c_vector_set_x, scm_c_vector_ref, scm_c_vector_set_x,
SCM_I_VECTOR_WELTS (array)); SCM_I_VECTOR_WELTS (array),
SCM_I_IS_MUTABLE_VECTOR (array));
break; break;
case scm_tc7_bitvector: case scm_tc7_bitvector:
initialize_vector_handle (h, scm_c_bitvector_length (array), initialize_vector_handle (h, scm_c_bitvector_length (array),
SCM_ARRAY_ELEMENT_TYPE_BIT, SCM_ARRAY_ELEMENT_TYPE_BIT,
scm_c_bitvector_ref, scm_c_bitvector_set_x, scm_c_bitvector_ref, scm_c_bitvector_set_x,
scm_i_bitvector_bits (array)); scm_i_bitvector_bits (array),
scm_i_is_mutable_bitvector (array));
break; break;
case scm_tc7_bytevector: case scm_tc7_bytevector:
{ {
@ -225,7 +229,8 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
} }
initialize_vector_handle (h, length, element_type, vref, vset, initialize_vector_handle (h, length, element_type, vref, vset,
SCM_BYTEVECTOR_CONTENTS (array)); SCM_BYTEVECTOR_CONTENTS (array),
SCM_MUTABLE_BYTEVECTOR_P (array));
} }
break; break;
case scm_tc7_array: case scm_tc7_array:
@ -320,15 +325,19 @@ scm_array_handle_release (scm_t_array_handle *h)
const SCM * const SCM *
scm_array_handle_elements (scm_t_array_handle *h) scm_array_handle_elements (scm_t_array_handle *h)
{ {
return scm_array_handle_writable_elements (h); if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
return ((const SCM *) h->elements) + h->base;
} }
SCM * SCM *
scm_array_handle_writable_elements (scm_t_array_handle *h) scm_array_handle_writable_elements (scm_t_array_handle *h)
{ {
if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) if (h->writable_elements != h->elements)
scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array");
return ((SCM*)h->elements) + h->base;
return (SCM *) scm_array_handle_elements (h);
} }
void void

2
libguile/array-map.c
View file

@ -263,6 +263,8 @@ racp (SCM src, SCM dst)
{ {
SCM const * el_s = h_s.elements; SCM const * el_s = h_s.elements;
SCM * el_d = h_d.writable_elements; SCM * el_d = h_d.writable_elements;
if (!el_d)
scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array");
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
el_d[i_d] = el_s[i_s]; el_d[i_d] = el_s[i_s];
} }

69
libguile/bitvectors.c
View file

@ -38,17 +38,30 @@
* but alack, all we have is this crufty C. * but alack, all we have is this crufty C.
*/ */
#define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj)) #define SCM_F_BITVECTOR_IMMUTABLE (0x80)
#define IS_BITVECTOR(obj) SCM_HAS_TYP7 ((obj), scm_tc7_bitvector)
#define IS_MUTABLE_BITVECTOR(x) \
(SCM_NIMP (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \
== scm_tc7_bitvector))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj)) #define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj)) #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj))
scm_t_uint32 *scm_i_bitvector_bits (SCM vec) scm_t_uint32 *
scm_i_bitvector_bits (SCM vec)
{ {
if (!IS_BITVECTOR (vec)) if (!IS_BITVECTOR (vec))
abort (); abort ();
return BITVECTOR_BITS (vec); return BITVECTOR_BITS (vec);
} }
int
scm_i_is_mutable_bitvector (SCM vec)
{
return IS_MUTABLE_BITVECTOR (vec);
}
int int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{ {
@ -166,18 +179,17 @@ SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
const scm_t_uint32 * const scm_t_uint32 *
scm_array_handle_bit_elements (scm_t_array_handle *h) scm_array_handle_bit_elements (scm_t_array_handle *h)
{ {
return scm_array_handle_bit_writable_elements (h); if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_BIT)
scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
return ((const scm_t_uint32 *) h->elements) + h->base/32;
} }
scm_t_uint32 * scm_t_uint32 *
scm_array_handle_bit_writable_elements (scm_t_array_handle *h) scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
{ {
SCM vec = h->array; if (h->writable_elements != h->elements)
if (SCM_I_ARRAYP (vec)) scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");
vec = SCM_I_ARRAY_V (vec); return (scm_t_uint32 *) scm_array_handle_bit_elements (h);
if (IS_BITVECTOR (vec))
return BITVECTOR_BITS (vec) + h->base/32;
scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
} }
size_t size_t
@ -193,7 +205,15 @@ scm_bitvector_elements (SCM vec,
size_t *lenp, size_t *lenp,
ssize_t *incp) ssize_t *incp)
{ {
return scm_bitvector_writable_elements (vec, h, offp, lenp, incp); scm_generalized_vector_get_handle (vec, h);
if (offp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*offp = scm_array_handle_bit_elements_offset (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_bit_elements (h);
} }
@ -204,15 +224,12 @@ scm_bitvector_writable_elements (SCM vec,
size_t *lenp, size_t *lenp,
ssize_t *incp) ssize_t *incp)
{ {
scm_generalized_vector_get_handle (vec, h); const scm_t_uint32 *ret = scm_bitvector_elements (vec, h, offp, lenp, incp);
if (offp)
{ if (h->writable_elements != h->elements)
scm_t_array_dim *dim = scm_array_handle_dims (h); scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");
*offp = scm_array_handle_bit_elements_offset (h);
*lenp = dim->ubnd - dim->lbnd + 1; return (scm_t_uint32 *) ret;
*incp = dim->inc;
}
return scm_array_handle_bit_writable_elements (h);
} }
SCM SCM
@ -260,7 +277,7 @@ scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
scm_t_array_handle handle; scm_t_array_handle handle;
scm_t_uint32 *bits, mask; scm_t_uint32 *bits, mask;
if (IS_BITVECTOR (vec)) if (IS_MUTABLE_BITVECTOR (vec))
{ {
if (idx >= BITVECTOR_LENGTH (vec)) if (idx >= BITVECTOR_LENGTH (vec))
scm_out_of_range (NULL, scm_from_size_t (idx)); scm_out_of_range (NULL, scm_from_size_t (idx));
@ -283,7 +300,7 @@ scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
else else
bits[idx/32] &= ~mask; bits[idx/32] &= ~mask;
if (!IS_BITVECTOR (vec)) if (!IS_MUTABLE_BITVECTOR (vec))
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
} }
@ -382,11 +399,10 @@ SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
scm_t_array_handle handle; scm_t_array_handle handle;
size_t off, len; size_t off, len;
ssize_t inc; ssize_t inc;
scm_t_uint32 *bits; const scm_t_uint32 *bits;
SCM res = SCM_EOL; SCM res = SCM_EOL;
bits = scm_bitvector_writable_elements (vec, &handle, bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
&off, &len, &inc);
if (off == 0 && inc == 1) if (off == 0 && inc == 1)
{ {
@ -446,12 +462,11 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
scm_t_array_handle handle; scm_t_array_handle handle;
size_t off, len; size_t off, len;
ssize_t inc; ssize_t inc;
scm_t_uint32 *bits; const scm_t_uint32 *bits;
int bit = scm_to_bool (b); int bit = scm_to_bool (b);
size_t count = 0; size_t count = 0;
bits = scm_bitvector_writable_elements (bitvector, &handle, bits = scm_bitvector_elements (bitvector, &handle, &off, &len, &inc);
&off, &len, &inc);
if (off == 0 && inc == 1 && len > 0) if (off == 0 && inc == 1 && len > 0)
{ {

1
libguile/bitvectors.h
View file

@ -71,6 +71,7 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
ssize_t *incp); ssize_t *incp);
SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec); SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec);
SCM_INTERNAL int scm_i_is_mutable_bitvector (SCM vec);
SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate); SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2); SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2);
SCM_INTERNAL void scm_init_bitvectors (void); SCM_INTERNAL void scm_init_bitvectors (void);

91
libguile/bytevectors.c
View file

@ -74,11 +74,11 @@
#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ #define INTEGER_ACCESSOR_PROLOGUE(validate, _len, _sign) \
size_t c_len, c_index; \ size_t c_len, c_index; \
_sign char *c_bv; \ _sign char *c_bv; \
\ \
SCM_VALIDATE_BYTEVECTOR (1, bv); \ SCM_VALIDATE_##validate (1, bv); \
c_index = scm_to_uint (index); \ c_index = scm_to_uint (index); \
\ \
c_len = SCM_BYTEVECTOR_LENGTH (bv); \ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
@ -87,11 +87,17 @@
if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
scm_out_of_range (FUNC_NAME, index); scm_out_of_range (FUNC_NAME, index);
#define INTEGER_GETTER_PROLOGUE(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _len, _sign)
#define INTEGER_SETTER_PROLOGUE(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _len, _sign)
/* Template for fixed-size integer access (only 8, 16 or 32-bit). */ /* Template for fixed-size integer access (only 8, 16 or 32-bit). */
#define INTEGER_REF(_len, _sign) \ #define INTEGER_REF(_len, _sign) \
SCM result; \ SCM result; \
\ \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_GETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \ SCM_VALIDATE_SYMBOL (3, endianness); \
\ \
{ \ { \
@ -110,7 +116,7 @@
#define INTEGER_NATIVE_REF(_len, _sign) \ #define INTEGER_NATIVE_REF(_len, _sign) \
SCM result; \ SCM result; \
\ \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_GETTER_PROLOGUE (_len, _sign); \
\ \
{ \ { \
INT_TYPE (_len, _sign) c_result; \ INT_TYPE (_len, _sign) c_result; \
@ -123,7 +129,7 @@
/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */ /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
#define INTEGER_SET(_len, _sign) \ #define INTEGER_SET(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_SETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \ SCM_VALIDATE_SYMBOL (3, endianness); \
\ \
{ \ { \
@ -149,7 +155,7 @@
/* Template for fixed-size integer modification using the native /* Template for fixed-size integer modification using the native
endianness. */ endianness. */
#define INTEGER_NATIVE_SET(_len, _sign) \ #define INTEGER_NATIVE_SET(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_SETTER_PROLOGUE (_len, _sign); \
\ \
{ \ { \
scm_t_signed_bits c_value; \ scm_t_signed_bits c_value; \
@ -176,22 +182,19 @@
#define SCM_BYTEVECTOR_HEADER_BYTES \ #define SCM_BYTEVECTOR_HEADER_BYTES \
(SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits)) (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
#define SCM_BYTEVECTOR_SET_FLAG(bv, flag) \
SCM_SET_BYTEVECTOR_FLAGS ((bv), SCM_BYTEVECTOR_FLAGS (bv) | flag)
#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len)) SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \ #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \
SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents)) SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
#define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \
SCM_SET_BYTEVECTOR_FLAGS ((bv), \
SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \
| ((contiguous_p) << 8UL))
#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
SCM_SET_BYTEVECTOR_FLAGS ((bv), \
(hint) \
| (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \ #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
SCM_SET_CELL_OBJECT_3 ((_bv), (_parent)) SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
#define SCM_VALIDATE_MUTABLE_BYTEVECTOR(pos, v) \
SCM_MAKE_VALIDATE_MSG (pos, v, MUTABLE_BYTEVECTOR_P, "mutable bytevector")
/* The empty bytevector. */ /* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED; SCM scm_null_bytevector = SCM_UNSPECIFIED;
@ -223,10 +226,10 @@ make_bytevector (size_t len, scm_t_array_element_type element_type)
ret = SCM_PACK_POINTER (contents); ret = SCM_PACK_POINTER (contents);
contents += SCM_BYTEVECTOR_HEADER_BYTES; contents += SCM_BYTEVECTOR_HEADER_BYTES;
SCM_SET_BYTEVECTOR_FLAGS (ret,
element_type | SCM_F_BYTEVECTOR_CONTIGUOUS);
SCM_BYTEVECTOR_SET_LENGTH (ret, c_len); SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
SCM_BYTEVECTOR_SET_CONTENTS (ret, contents); SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F); SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
} }
@ -253,10 +256,9 @@ make_bytevector_from_buffer (size_t len, void *contents,
c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
SCM_SET_BYTEVECTOR_FLAGS (ret, element_type);
SCM_BYTEVECTOR_SET_LENGTH (ret, c_len); SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
SCM_BYTEVECTOR_SET_CONTENTS (ret, contents); SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F); SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
} }
@ -390,7 +392,7 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
size_t c_len; size_t c_len;
scm_t_uint8 *c_bv; scm_t_uint8 *c_bv;
SCM_VALIDATE_BYTEVECTOR (1, bv); SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
c_len = SCM_BYTEVECTOR_LENGTH (bv); c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv); c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
@ -551,7 +553,7 @@ SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
scm_t_uint8 *c_bv, c_fill; scm_t_uint8 *c_bv, c_fill;
int value; int value;
SCM_VALIDATE_BYTEVECTOR (1, bv); SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
value = scm_to_int (fill); value = scm_to_int (fill);
if (SCM_UNLIKELY ((value < -128) || (value > 255))) if (SCM_UNLIKELY ((value < -128) || (value > 255)))
@ -582,7 +584,7 @@ SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
signed char *c_source, *c_target; signed char *c_source, *c_target;
SCM_VALIDATE_BYTEVECTOR (1, source); SCM_VALIDATE_BYTEVECTOR (1, source);
SCM_VALIDATE_BYTEVECTOR (3, target); SCM_VALIDATE_MUTABLE_BYTEVECTOR (3, target);
c_len = scm_to_size_t (len); c_len = scm_to_size_t (len);
c_source_start = scm_to_size_t (source_start); c_source_start = scm_to_size_t (source_start);
@ -707,8 +709,6 @@ SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
#undef OCTET_ACCESSOR_PROLOGUE
SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0, SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
(SCM bv), (SCM bv),
@ -895,11 +895,11 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
return err; return err;
} }
#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \ #define GENERIC_INTEGER_ACCESSOR_PROLOGUE(validate, _sign) \
size_t c_len, c_index, c_size; \ size_t c_len, c_index, c_size; \
char *c_bv; \ char *c_bv; \
\ \
SCM_VALIDATE_BYTEVECTOR (1, bv); \ SCM_VALIDATE_##validate (1, bv); \
c_index = scm_to_size_t (index); \ c_index = scm_to_size_t (index); \
c_size = scm_to_size_t (size); \ c_size = scm_to_size_t (size); \
\ \
@ -914,6 +914,10 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
if (SCM_UNLIKELY (c_index + c_size > c_len)) \ if (SCM_UNLIKELY (c_index + c_size > c_len)) \
scm_out_of_range (FUNC_NAME, index); scm_out_of_range (FUNC_NAME, index);
#define GENERIC_INTEGER_GETTER_PROLOGUE(_sign) \
GENERIC_INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _sign)
#define GENERIC_INTEGER_SETTER_PROLOGUE(_sign) \
GENERIC_INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _sign)
/* Template of an integer reference function. */ /* Template of an integer reference function. */
#define GENERIC_INTEGER_REF(_sign) \ #define GENERIC_INTEGER_REF(_sign) \
@ -1063,7 +1067,7 @@ SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
"@var{index} in @var{bv}.") "@var{index} in @var{bv}.")
#define FUNC_NAME s_scm_bytevector_uint_ref #define FUNC_NAME s_scm_bytevector_uint_ref
{ {
GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); GENERIC_INTEGER_GETTER_PROLOGUE (unsigned);
return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness)); return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
} }
@ -1075,7 +1079,7 @@ SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
"@var{index} in @var{bv}.") "@var{index} in @var{bv}.")
#define FUNC_NAME s_scm_bytevector_sint_ref #define FUNC_NAME s_scm_bytevector_sint_ref
{ {
GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); GENERIC_INTEGER_GETTER_PROLOGUE (signed);
return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness)); return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
} }
@ -1087,7 +1091,7 @@ SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
"to @var{value}.") "to @var{value}.")
#define FUNC_NAME s_scm_bytevector_uint_set_x #define FUNC_NAME s_scm_bytevector_uint_set_x
{ {
GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); GENERIC_INTEGER_SETTER_PROLOGUE (unsigned);
bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness, bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
FUNC_NAME); FUNC_NAME);
@ -1102,7 +1106,7 @@ SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
"to @var{value}.") "to @var{value}.")
#define FUNC_NAME s_scm_bytevector_sint_set_x #define FUNC_NAME s_scm_bytevector_sint_set_x
{ {
GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); GENERIC_INTEGER_SETTER_PROLOGUE (signed);
bytevector_signed_set (&c_bv[c_index], c_size, value, endianness, bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
FUNC_NAME); FUNC_NAME);
@ -1330,7 +1334,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
`large_{ref,set}' variants on 32-bit machines. */ `large_{ref,set}' variants on 32-bit machines. */
#define LARGE_INTEGER_REF(_len, _sign) \ #define LARGE_INTEGER_REF(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ INTEGER_GETTER_PROLOGUE(_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \ SCM_VALIDATE_SYMBOL (3, endianness); \
\ \
return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
@ -1338,7 +1342,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
#define LARGE_INTEGER_SET(_len, _sign) \ #define LARGE_INTEGER_SET(_len, _sign) \
int err; \ int err; \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_SETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (4, endianness); \ SCM_VALIDATE_SYMBOL (4, endianness); \
\ \
err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
@ -1348,14 +1352,14 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
\ \
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ #define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ INTEGER_GETTER_PROLOGUE(_len, _sign); \
return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
SIGNEDNESS (_sign), scm_i_native_endianness)); SIGNEDNESS (_sign), scm_i_native_endianness));
#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
int err; \ int err; \
INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ INTEGER_SETTER_PROLOGUE (_len, _sign); \
\ \
err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
SIGNEDNESS (_sign), value, \ SIGNEDNESS (_sign), value, \
@ -1665,13 +1669,16 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
/* Templace getters and setters. */ /* Templace getters and setters. */
#define IEEE754_ACCESSOR_PROLOGUE(_type) \ #define IEEE754_GETTER_PROLOGUE(_type) \
INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed); INTEGER_GETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
#define IEEE754_SETTER_PROLOGUE(_type) \
INTEGER_SETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
#define IEEE754_REF(_type) \ #define IEEE754_REF(_type) \
_type c_result; \ _type c_result; \
\ \
IEEE754_ACCESSOR_PROLOGUE (_type); \ IEEE754_GETTER_PROLOGUE (_type); \
SCM_VALIDATE_SYMBOL (3, endianness); \ SCM_VALIDATE_SYMBOL (3, endianness); \
\ \
if (scm_is_eq (endianness, scm_i_native_endianness)) \ if (scm_is_eq (endianness, scm_i_native_endianness)) \
@ -1690,7 +1697,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
#define IEEE754_NATIVE_REF(_type) \ #define IEEE754_NATIVE_REF(_type) \
_type c_result; \ _type c_result; \
\ \
IEEE754_ACCESSOR_PROLOGUE (_type); \ IEEE754_GETTER_PROLOGUE (_type); \
\ \
memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
return (IEEE754_TO_SCM (_type) (c_result)); return (IEEE754_TO_SCM (_type) (c_result));
@ -1698,7 +1705,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
#define IEEE754_SET(_type) \ #define IEEE754_SET(_type) \
_type c_value; \ _type c_value; \
\ \
IEEE754_ACCESSOR_PROLOGUE (_type); \ IEEE754_SETTER_PROLOGUE (_type); \
VALIDATE_REAL (3, value); \ VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \ SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \ c_value = IEEE754_FROM_SCM (_type) (value); \
@ -1718,7 +1725,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
#define IEEE754_NATIVE_SET(_type) \ #define IEEE754_NATIVE_SET(_type) \
_type c_value; \ _type c_value; \
\ \
IEEE754_ACCESSOR_PROLOGUE (_type); \ IEEE754_SETTER_PROLOGUE (_type); \
VALIDATE_REAL (3, value); \ VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \ c_value = IEEE754_FROM_SCM (_type) (value); \
\ \

10
libguile/bytevectors.h
View file

@ -124,10 +124,18 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
SCM_SET_CELL_TYPE ((_bv), \ SCM_SET_CELL_TYPE ((_bv), \
scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL)) scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL))
#define SCM_F_BYTEVECTOR_CONTIGUOUS 0x100UL
#define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL
#define SCM_MUTABLE_BYTEVECTOR_P(x) \
(SCM_NIMP (x) && \
((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \
== scm_tc7_bytevector))
#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \ #define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL) (SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL)
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \ #define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \
(SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL) (SCM_BYTEVECTOR_FLAGS (_bv) & SCM_F_BYTEVECTOR_CONTIGUOUS)
#define SCM_BYTEVECTOR_TYPE_SIZE(var) \ #define SCM_BYTEVECTOR_TYPE_SIZE(var) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8) (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)

25
libguile/srfi-4.c
View file

@ -119,23 +119,17 @@
{ \ { \
if (h->element_type != ETYPE (TAG)) \ if (h->element_type != ETYPE (TAG)) \
scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
return ((const ctype*) h->elements) + h->base*width; \ return ((const ctype *) h->elements) + h->base*width; \
} \ } \
ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \ ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
{ \ { \
if (h->element_type != ETYPE (TAG)) \ if (h->writable_elements != h->elements) \
scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable " #tag "vector"); \
return ((ctype*) h->writable_elements) + h->base*width; \ return (ctype *) scm_array_handle_##tag##_elements (h); \
} \ } \
const ctype *scm_##tag##vector_elements (SCM uvec, \ const ctype *scm_##tag##vector_elements (SCM uvec, \
scm_t_array_handle *h, \ scm_t_array_handle *h, \
size_t *lenp, ssize_t *incp) \ size_t *lenp, ssize_t *incp) \
{ \
return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
} \
ctype *scm_##tag##vector_writable_elements (SCM uvec, \
scm_t_array_handle *h, \
size_t *lenp, ssize_t *incp) \
{ \ { \
size_t byte_width = width * sizeof (ctype); \ size_t byte_width = width * sizeof (ctype); \
if (!scm_is_bytevector (uvec) \ if (!scm_is_bytevector (uvec) \
@ -146,7 +140,16 @@
*lenp = scm_c_bytevector_length (uvec) / byte_width; \ *lenp = scm_c_bytevector_length (uvec) / byte_width; \
if (incp) \ if (incp) \
*incp = 1; \ *incp = 1; \
return ((ctype *)h->writable_elements); \ return ((const ctype *) h->elements); \
} \
ctype *scm_##tag##vector_writable_elements (SCM uvec, \
scm_t_array_handle *h, \
size_t *lenp, ssize_t *incp) \
{ \
const ctype *ret = scm_##tag##vector_elements (uvec, h, lenp, incp);\
if (h->writable_elements != h->elements) \
scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable " #tag "vector"); \
return (ctype *) ret; \
} }

6
libguile/strings.c
View file

@ -507,6 +507,12 @@ scm_i_string_length (SCM str)
return STRING_LENGTH (str); return STRING_LENGTH (str);
} }
int
scm_i_string_is_mutable (SCM str)
{
return !IS_RO_STRING (str);
}
/* True if the string is 'narrow', meaning it has a 8-bit Latin-1 /* True if the string is 'narrow', meaning it has a 8-bit Latin-1
encoding. False if it is 'wide', having a 32-bit UCS-4 encoding. False if it is 'wide', having a 32-bit UCS-4
encoding. */ encoding. */

2
libguile/strings.h
View file

@ -194,12 +194,12 @@ SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap,
int read_only_p); int read_only_p);
SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap, SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap,
int read_only_p); int read_only_p);
SCM_INTERNAL SCM scm_i_set_string_read_only_x (SCM str);
SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
SCM_INTERNAL size_t scm_i_string_length (SCM str); SCM_INTERNAL size_t scm_i_string_length (SCM str);
SCM_INTERNAL int scm_i_string_is_mutable (SCM str);
SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str); SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str);
SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str); SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str);
SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str); SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str);

15
libguile/uniform.c
View file

@ -67,18 +67,21 @@ scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
const void * const void *
scm_array_handle_uniform_elements (scm_t_array_handle *h) scm_array_handle_uniform_elements (scm_t_array_handle *h)
{ {
return scm_array_handle_uniform_writable_elements (h); size_t esize;
const scm_t_uint8 *ret;
esize = scm_array_handle_uniform_element_size (h);
ret = ((const scm_t_uint8 *) h->elements) + h->base * esize;
return ret;
} }
void * void *
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{ {
size_t esize; if (h->writable_elements != h->elements)
scm_t_uint8 *ret; scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array");
esize = scm_array_handle_uniform_element_size (h); return (void *) scm_array_handle_uniform_elements (h);
ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
return ret;
} }
void void

30
libguile/vectors.c
View file

@ -42,6 +42,12 @@
#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
#define SCM_VALIDATE_MUTABLE_VECTOR(pos, v) \
do { \
SCM_ASSERT (SCM_I_IS_MUTABLE_VECTOR (v), v, pos, FUNC_NAME); \
} while (0)
int int
scm_is_vector (SCM obj) scm_is_vector (SCM obj)
{ {
@ -57,14 +63,6 @@ scm_is_simple_vector (SCM obj)
const SCM * const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h, scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp) size_t *lenp, ssize_t *incp)
{
/* guard against weak vectors in the next call */
return scm_vector_writable_elements (vec, h, lenp, incp);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{ {
/* it's unsafe to access the memory of a weak vector */ /* it's unsafe to access the memory of a weak vector */
if (SCM_I_WVECTP (vec)) if (SCM_I_WVECTP (vec))
@ -77,7 +75,19 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
*lenp = dim->ubnd - dim->lbnd + 1; *lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc; *incp = dim->inc;
} }
return scm_array_handle_writable_elements (h); return scm_array_handle_elements (h);
}
SCM *
scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
const SCM *ret = scm_vector_elements (vec, h, lenp, incp);
if (h->writable_elements != h->elements)
scm_wrong_type_arg_msg (NULL, 0, vec, "mutable vector");
return (SCM *) ret;
} }
SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
@ -203,7 +213,7 @@ void
scm_c_vector_set_x (SCM v, size_t k, SCM obj) scm_c_vector_set_x (SCM v, size_t k, SCM obj)
#define FUNC_NAME s_scm_vector_set_x #define FUNC_NAME s_scm_vector_set_x
{ {
SCM_VALIDATE_VECTOR (1, v); SCM_VALIDATE_MUTABLE_VECTOR (1, v);
if (k >= SCM_I_VECTOR_LENGTH (v)) if (k >= SCM_I_VECTOR_LENGTH (v))
scm_out_of_range (NULL, scm_from_size_t (k)); scm_out_of_range (NULL, scm_from_size_t (k));

8
libguile/vectors.h
View file

@ -63,6 +63,14 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
/* Internals */ /* Internals */
/* Vectors residualized into compiled objects have scm_tc7_vector in the
low 7 bits, but also an additional bit set to indicate
immutability. */
#define SCM_F_VECTOR_IMMUTABLE 0x80UL
#define SCM_I_IS_MUTABLE_VECTOR(x) \
(SCM_NIMP (x) && \
((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \
== scm_tc7_vector))
#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector)) #define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x)) #define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1)) #define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))

12
libguile/vm-engine.c
View file

@ -420,6 +420,8 @@
VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box) VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box)
#define VM_VALIDATE_BYTEVECTOR(x, proc) \ #define VM_VALIDATE_BYTEVECTOR(x, proc) \
VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector)
#define VM_VALIDATE_MUTABLE_BYTEVECTOR(obj, proc) \
VM_VALIDATE (obj, SCM_MUTABLE_BYTEVECTOR_P, proc, mutable_bytevector)
#define VM_VALIDATE_CHAR(x, proc) \ #define VM_VALIDATE_CHAR(x, proc) \
VM_VALIDATE (x, SCM_CHARP, proc, char) VM_VALIDATE (x, SCM_CHARP, proc, char)
#define VM_VALIDATE_PAIR(x, proc) \ #define VM_VALIDATE_PAIR(x, proc) \
@ -434,6 +436,8 @@
VM_VALIDATE (obj, SCM_VARIABLEP, proc, variable) VM_VALIDATE (obj, SCM_VARIABLEP, proc, variable)
#define VM_VALIDATE_VECTOR(obj, proc) \ #define VM_VALIDATE_VECTOR(obj, proc) \
VM_VALIDATE (obj, SCM_I_IS_VECTOR, proc, vector) VM_VALIDATE (obj, SCM_I_IS_VECTOR, proc, vector)
#define VM_VALIDATE_MUTABLE_VECTOR(obj, proc) \
VM_VALIDATE (obj, SCM_I_IS_MUTABLE_VECTOR, proc, mutable_vector)
#define VM_VALIDATE_INDEX(u64, size, proc) \ #define VM_VALIDATE_INDEX(u64, size, proc) \
VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64)) VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64))
@ -2690,7 +2694,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
c_idx = SP_REF_U64 (idx); c_idx = SP_REF_U64 (idx);
val = SP_REF (src); val = SP_REF (src);
VM_VALIDATE_VECTOR (vect, "vector-set!"); VM_VALIDATE_MUTABLE_VECTOR (vect, "vector-set!");
VM_VALIDATE_INDEX (c_idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); VM_VALIDATE_INDEX (c_idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!");
SCM_I_VECTOR_WELTS (vect)[c_idx] = val; SCM_I_VECTOR_WELTS (vect)[c_idx] = val;
NEXT (1); NEXT (1);
@ -2710,7 +2714,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
vect = SP_REF (dst); vect = SP_REF (dst);
val = SP_REF (src); val = SP_REF (src);
VM_VALIDATE_VECTOR (vect, "vector-set!"); VM_VALIDATE_MUTABLE_VECTOR (vect, "vector-set!");
VM_VALIDATE_INDEX (idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); VM_VALIDATE_INDEX (idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!");
SCM_I_VECTOR_WELTS (vect)[idx] = val; SCM_I_VECTOR_WELTS (vect)[idx] = val;
NEXT (1); NEXT (1);
@ -3044,7 +3048,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
c_idx = SP_REF_U64 (idx); \ c_idx = SP_REF_U64 (idx); \
slot_val = SP_REF_ ## slot (src); \ slot_val = SP_REF_ ## slot (src); \
\ \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ VM_VALIDATE_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
\ \
VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \
&& SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \
@ -3070,7 +3074,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
c_idx = SP_REF_U64 (idx); \ c_idx = SP_REF_U64 (idx); \
val = SP_REF_ ## slot (src); \ val = SP_REF_ ## slot (src); \
\ \
VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ VM_VALIDATE_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
\ \
VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \
&& SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \

14
libguile/vm.c
View file

@ -433,8 +433,10 @@ static void vm_error_not_a_mutable_pair (const char *subr, SCM x) SCM_NORETURN S
static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_mutable_bytevector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_mutable_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE;
static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
@ -552,6 +554,12 @@ vm_error_not_a_bytevector (const char *subr, SCM x)
scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
} }
static void
vm_error_not_a_mutable_bytevector (const char *subr, SCM x)
{
scm_wrong_type_arg_msg (subr, 1, x, "mutable bytevector");
}
static void static void
vm_error_not_a_struct (const char *subr, SCM x) vm_error_not_a_struct (const char *subr, SCM x)
{ {
@ -564,6 +572,12 @@ vm_error_not_a_vector (const char *subr, SCM x)
scm_wrong_type_arg_msg (subr, 1, x, "vector"); scm_wrong_type_arg_msg (subr, 1, x, "vector");
} }
static void
vm_error_not_a_mutable_vector (const char *subr, SCM x)
{
scm_wrong_type_arg_msg (subr, 1, x, "mutable vector");
}
static void static void
vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx)
{ {

54
module/system/vm/assembler.scm
View file

@ -1392,17 +1392,27 @@ should be .data or .rodata), and return the resulting linker object.
(+ address (+ address
(modulo (- alignment (modulo address alignment)) alignment))) (modulo (- alignment (modulo address alignment)) alignment)))
(define tc7-vector 13) (define tc7-vector #x0d)
(define vector-immutable-flag #x80)
(define tc7-string #x15)
(define string-read-only-flag #x200)
(define tc7-stringbuf #x27)
(define stringbuf-wide-flag #x400) (define stringbuf-wide-flag #x400)
(define tc7-stringbuf 39)
(define tc7-narrow-stringbuf tc7-stringbuf)
(define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag))
(define tc7-ro-string (+ 21 #x200))
(define tc7-syntax #x3d) (define tc7-syntax #x3d)
(define tc7-program 69)
(define tc7-bytevector 77) (define tc7-program #x45)
(define tc7-bitvector 95)
(define tc7-array 93) (define tc7-bytevector #x4d)
;; This flag is intended to be left-shifted by 7 bits.
(define bytevector-immutable-flag #x200)
(define tc7-array #x5d)
(define tc7-bitvector #x5f)
(define bitvector-immutable-flag #x80)
(let ((word-size (asm-word-size asm)) (let ((word-size (asm-word-size asm))
(endianness (asm-endianness asm))) (endianness (asm-endianness asm)))
@ -1447,9 +1457,10 @@ should be .data or .rodata), and return the resulting linker object.
((stringbuf? obj) ((stringbuf? obj)
(let* ((x (stringbuf-string obj)) (let* ((x (stringbuf-string obj))
(len (string-length x)) (len (string-length x))
(tag (if (= (string-bytes-per-char x) 1) (tag (logior tc7-stringbuf
tc7-narrow-stringbuf (if (= (string-bytes-per-char x) 1)
tc7-wide-stringbuf))) 0
stringbuf-wide-flag))))
(case word-size (case word-size
((4) ((4)
(bytevector-u32-set! buf pos tag endianness) (bytevector-u32-set! buf pos tag endianness)
@ -1491,15 +1502,15 @@ should be .data or .rodata), and return the resulting linker object.
(write-placeholder asm buf pos)) (write-placeholder asm buf pos))
((string? obj) ((string? obj)
(let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused? (let ((tag (logior tc7-string string-read-only-flag)))
(case word-size (case word-size
((4) ((4)
(bytevector-u32-set! buf pos tc7-ro-string endianness) (bytevector-u32-set! buf pos tag endianness)
(write-placeholder asm buf (+ pos 4)) ; stringbuf (write-placeholder asm buf (+ pos 4)) ; stringbuf
(bytevector-u32-set! buf (+ pos 8) 0 endianness) (bytevector-u32-set! buf (+ pos 8) 0 endianness)
(bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness)) (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
((8) ((8)
(bytevector-u64-set! buf pos tc7-ro-string endianness) (bytevector-u64-set! buf pos tag endianness)
(write-placeholder asm buf (+ pos 8)) ; stringbuf (write-placeholder asm buf (+ pos 8)) ; stringbuf
(bytevector-u64-set! buf (+ pos 16) 0 endianness) (bytevector-u64-set! buf (+ pos 16) 0 endianness)
(bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness)) (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
@ -1511,7 +1522,7 @@ should be .data or .rodata), and return the resulting linker object.
((simple-vector? obj) ((simple-vector? obj)
(let* ((len (vector-length obj)) (let* ((len (vector-length obj))
(tag (logior tc7-vector (ash len 8)))) (tag (logior tc7-vector vector-immutable-flag (ash len 8))))
(case word-size (case word-size
((4) (bytevector-u32-set! buf pos tag endianness)) ((4) (bytevector-u32-set! buf pos tag endianness))
((8) (bytevector-u64-set! buf pos tag endianness)) ((8) (bytevector-u64-set! buf pos tag endianness))
@ -1546,9 +1557,14 @@ should be .data or .rodata), and return the resulting linker object.
((simple-uniform-vector? obj) ((simple-uniform-vector? obj)
(let ((tag (if (bitvector? obj) (let ((tag (if (bitvector? obj)
tc7-bitvector (logior tc7-bitvector
(let ((type-code (array-type-code obj))) bitvector-immutable-flag)
(logior tc7-bytevector (ash type-code 7)))))) (logior tc7-bytevector
;; Bytevector immutable flag also shifted
;; left.
(ash (logior bytevector-immutable-flag
(array-type-code obj))
7)))))
(case word-size (case word-size
((4) ((4)
(bytevector-u32-set! buf pos tag endianness) (bytevector-u32-set! buf pos tag endianness)