[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/05: All literal constants are read-only
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/05: All literal constants are read-only |
|
Date: |
Tue, 18 Apr 2017 15:38:36 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 7ed54fd36d2e381aa46ef8a7d2fc13a6776b573a
Author: Andy Wingo <address@hidden>
Date: Tue Apr 18 14:56:48 2017 +0200
All literal constants are read-only
* 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.
---
libguile/array-handle.c | 29 +++++++++-----
libguile/array-map.c | 2 +
libguile/bitvectors.c | 69 +++++++++++++++++++-------------
libguile/bitvectors.h | 1 +
libguile/bytevectors.c | 91 +++++++++++++++++++++++-------------------
libguile/bytevectors.h | 10 ++++-
libguile/srfi-4.c | 25 +++++++-----
libguile/strings.c | 6 +++
libguile/strings.h | 2 +-
libguile/uniform.c | 15 ++++---
libguile/vectors.c | 30 +++++++++-----
libguile/vectors.h | 8 ++++
libguile/vm-engine.c | 12 ++++--
libguile/vm.c | 14 +++++++
module/system/vm/assembler.scm | 54 ++++++++++++++++---------
15 files changed, 237 insertions(+), 131 deletions(-)
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 89277d9..3d81efc 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -140,7 +140,7 @@ static void
initialize_vector_handle (scm_t_array_handle *h, size_t len,
scm_t_array_element_type element_type,
scm_t_vector_ref vref, scm_t_vector_set vset,
- void *writable_elements)
+ const void *elements, int mutable_p)
{
h->base = 0;
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.inc = 1;
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->vref = vref;
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),
SCM_ARRAY_ELEMENT_TYPE_CHAR,
scm_c_string_ref, scm_c_string_set_x,
- NULL);
+ NULL,
+ scm_i_string_is_mutable (array));
break;
case scm_tc7_vector:
initialize_vector_handle (h, scm_c_vector_length (array),
SCM_ARRAY_ELEMENT_TYPE_SCM,
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;
case scm_tc7_bitvector:
initialize_vector_handle (h, scm_c_bitvector_length (array),
SCM_ARRAY_ELEMENT_TYPE_BIT,
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;
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,
- SCM_BYTEVECTOR_CONTENTS (array));
+ SCM_BYTEVECTOR_CONTENTS (array),
+ SCM_MUTABLE_BYTEVECTOR_P (array));
}
break;
case scm_tc7_array:
@@ -320,15 +325,19 @@ scm_array_handle_release (scm_t_array_handle *h)
const SCM *
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_array_handle_writable_elements (scm_t_array_handle *h)
{
- if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
- scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
- return ((SCM*)h->elements) + h->base;
+ if (h->writable_elements != h->elements)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array");
+
+ return (SCM *) scm_array_handle_elements (h);
}
void
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c2825bc..7938396 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -263,6 +263,8 @@ racp (SCM src, SCM dst)
{
SCM const * el_s = h_s.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)
el_d[i_d] = el_s[i_s];
}
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 7a4ed9b..cfca4ab 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -38,11 +38,18 @@
* 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_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))
abort ();
@@ -50,6 +57,12 @@ scm_t_uint32 *scm_i_bitvector_bits (SCM vec)
}
int
+scm_i_is_mutable_bitvector (SCM vec)
+{
+ return IS_MUTABLE_BITVECTOR (vec);
+}
+
+int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
{
size_t bit_len = BITVECTOR_LENGTH (vec);
@@ -166,18 +179,17 @@ SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1,
0, 0,
const scm_t_uint32 *
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_array_handle_bit_writable_elements (scm_t_array_handle *h)
{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (IS_BITVECTOR (vec))
- return BITVECTOR_BITS (vec) + h->base/32;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
+ if (h->writable_elements != h->elements)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");
+ return (scm_t_uint32 *) scm_array_handle_bit_elements (h);
}
size_t
@@ -193,7 +205,15 @@ scm_bitvector_elements (SCM vec,
size_t *lenp,
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,
ssize_t *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_writable_elements (h);
+ const scm_t_uint32 *ret = scm_bitvector_elements (vec, h, offp, lenp, incp);
+
+ if (h->writable_elements != h->elements)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array");
+
+ return (scm_t_uint32 *) ret;
}
SCM
@@ -260,7 +277,7 @@ scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
scm_t_array_handle handle;
scm_t_uint32 *bits, mask;
- if (IS_BITVECTOR (vec))
+ if (IS_MUTABLE_BITVECTOR (vec))
{
if (idx >= BITVECTOR_LENGTH (vec))
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
bits[idx/32] &= ~mask;
- if (!IS_BITVECTOR (vec))
+ if (!IS_MUTABLE_BITVECTOR (vec))
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;
size_t off, len;
ssize_t inc;
- scm_t_uint32 *bits;
+ const scm_t_uint32 *bits;
SCM res = SCM_EOL;
- bits = scm_bitvector_writable_elements (vec, &handle,
- &off, &len, &inc);
+ bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
if (off == 0 && inc == 1)
{
@@ -446,12 +462,11 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
scm_t_array_handle handle;
size_t off, len;
ssize_t inc;
- scm_t_uint32 *bits;
+ const scm_t_uint32 *bits;
int bit = scm_to_bool (b);
size_t count = 0;
- bits = scm_bitvector_writable_elements (bitvector, &handle,
- &off, &len, &inc);
+ bits = scm_bitvector_elements (bitvector, &handle, &off, &len, &inc);
if (off == 0 && inc == 1 && len > 0)
{
diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h
index 6b2cb1e..57ae52f 100644
--- a/libguile/bitvectors.h
+++ b/libguile/bitvectors.h
@@ -71,6 +71,7 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM
vec,
ssize_t *incp);
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 SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2);
SCM_INTERNAL void scm_init_bitvectors (void);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 7b4585d..7cd7530 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -74,11 +74,11 @@
#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
-#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
+#define INTEGER_ACCESSOR_PROLOGUE(validate, _len, _sign) \
size_t c_len, c_index; \
_sign char *c_bv; \
\
- SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_##validate (1, bv); \
c_index = scm_to_uint (index); \
\
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
@@ -87,11 +87,17 @@
if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
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). */
#define INTEGER_REF(_len, _sign) \
SCM result; \
\
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_GETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \
\
{ \
@@ -110,7 +116,7 @@
#define INTEGER_NATIVE_REF(_len, _sign) \
SCM result; \
\
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_GETTER_PROLOGUE (_len, _sign); \
\
{ \
INT_TYPE (_len, _sign) c_result; \
@@ -123,7 +129,7 @@
/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
#define INTEGER_SET(_len, _sign) \
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_SETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \
\
{ \
@@ -149,7 +155,7 @@
/* Template for fixed-size integer modification using the native
endianness. */
#define INTEGER_NATIVE_SET(_len, _sign) \
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_SETTER_PROLOGUE (_len, _sign); \
\
{ \
scm_t_signed_bits c_value; \
@@ -176,22 +182,19 @@
#define SCM_BYTEVECTOR_HEADER_BYTES \
(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) \
SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _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) \
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. */
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);
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_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);
}
@@ -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);
+ SCM_SET_BYTEVECTOR_FLAGS (ret, element_type);
SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
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);
}
@@ -390,7 +392,7 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8
value)
size_t c_len;
scm_t_uint8 *c_bv;
- SCM_VALIDATE_BYTEVECTOR (1, bv);
+ SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
c_len = SCM_BYTEVECTOR_LENGTH (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;
int value;
- SCM_VALIDATE_BYTEVECTOR (1, bv);
+ SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv);
value = scm_to_int (fill);
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;
SCM_VALIDATE_BYTEVECTOR (1, source);
- SCM_VALIDATE_BYTEVECTOR (3, target);
+ SCM_VALIDATE_MUTABLE_BYTEVECTOR (3, target);
c_len = scm_to_size_t (len);
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 OCTET_ACCESSOR_PROLOGUE
-
SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
(SCM bv),
@@ -895,11 +895,11 @@ bytevector_large_set (char *c_bv, size_t c_size, int
signed_p,
return err;
}
-#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
+#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(validate, _sign) \
size_t c_len, c_index, c_size; \
char *c_bv; \
\
- SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_##validate (1, bv); \
c_index = scm_to_size_t (index); \
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)) \
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. */
#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}.")
#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));
}
@@ -1075,7 +1079,7 @@ SCM_DEFINE (scm_bytevector_sint_ref,
"bytevector-sint-ref", 4, 0, 0,
"@var{index} in @var{bv}.")
#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));
}
@@ -1087,7 +1091,7 @@ SCM_DEFINE (scm_bytevector_uint_set_x,
"bytevector-uint-set!", 5, 0, 0,
"to @var{value}.")
#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,
FUNC_NAME);
@@ -1102,7 +1106,7 @@ SCM_DEFINE (scm_bytevector_sint_set_x,
"bytevector-sint-set!", 5, 0, 0,
"to @var{value}.")
#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,
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. */
#define LARGE_INTEGER_REF(_len, _sign) \
- INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ INTEGER_GETTER_PROLOGUE(_len, _sign); \
SCM_VALIDATE_SYMBOL (3, endianness); \
\
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) \
int err; \
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_SETTER_PROLOGUE (_len, _sign); \
SCM_VALIDATE_SYMBOL (4, endianness); \
\
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;
-#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
- INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
- return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
+ INTEGER_GETTER_PROLOGUE(_len, _sign); \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
SIGNEDNESS (_sign), scm_i_native_endianness));
#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
int err; \
- INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ INTEGER_SETTER_PROLOGUE (_len, _sign); \
\
err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
SIGNEDNESS (_sign), value, \
@@ -1665,13 +1669,16 @@ double_from_foreign_endianness (const union
scm_ieee754_double *source)
/* Templace getters and setters. */
-#define IEEE754_ACCESSOR_PROLOGUE(_type) \
- INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
+#define IEEE754_GETTER_PROLOGUE(_type) \
+ INTEGER_GETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
+
+#define IEEE754_SETTER_PROLOGUE(_type) \
+ INTEGER_SETTER_PROLOGUE (sizeof (_type) << 3UL, signed);
#define IEEE754_REF(_type) \
_type c_result; \
\
- IEEE754_ACCESSOR_PROLOGUE (_type); \
+ IEEE754_GETTER_PROLOGUE (_type); \
SCM_VALIDATE_SYMBOL (3, 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) \
_type c_result; \
\
- IEEE754_ACCESSOR_PROLOGUE (_type); \
+ IEEE754_GETTER_PROLOGUE (_type); \
\
memcpy (&c_result, &c_bv[c_index], sizeof (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) \
_type c_value; \
\
- IEEE754_ACCESSOR_PROLOGUE (_type); \
+ IEEE754_SETTER_PROLOGUE (_type); \
VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \
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) \
_type c_value; \
\
- IEEE754_ACCESSOR_PROLOGUE (_type); \
+ IEEE754_SETTER_PROLOGUE (_type); \
VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index af4ac1c..77f0006 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -124,10 +124,18 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
SCM_SET_CELL_TYPE ((_bv), \
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) \
(SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL)
#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) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 057664c..b0ed0ce 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -119,24 +119,18 @@
{ \
if (h->element_type != ETYPE (TAG)) \
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) \
{ \
- if (h->element_type != ETYPE (TAG)) \
- scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
- return ((ctype*) h->writable_elements) + h->base*width; \
+ if (h->writable_elements != h->elements) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable " #tag "vector"); \
+ return (ctype *) scm_array_handle_##tag##_elements (h); \
} \
const ctype *scm_##tag##vector_elements (SCM uvec, \
scm_t_array_handle *h, \
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); \
if (!scm_is_bytevector (uvec) \
|| (scm_c_bytevector_length (uvec) % byte_width)) \
@@ -146,7 +140,16 @@
*lenp = scm_c_bytevector_length (uvec) / byte_width; \
if (incp) \
*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; \
}
diff --git a/libguile/strings.c b/libguile/strings.c
index 8d0aa45..5c49e33 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -507,6 +507,12 @@ scm_i_string_length (SCM 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
encoding. False if it is 'wide', having a 32-bit UCS-4
encoding. */
diff --git a/libguile/strings.h b/libguile/strings.h
index 77690ce..5b3e780 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -194,12 +194,12 @@ SCM_INTERNAL SCM scm_i_make_string (size_t len, char
**datap,
int read_only_p);
SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap,
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_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_copy (SCM str, size_t start, size_t end);
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 */ char *scm_i_string_writable_chars (SCM str);
SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str);
diff --git a/libguile/uniform.c b/libguile/uniform.c
index f7ca7bc..13ee18a 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -67,18 +67,21 @@ scm_array_handle_uniform_element_bit_size
(scm_t_array_handle *h)
const void *
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 *
scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
{
- size_t esize;
- scm_t_uint8 *ret;
+ if (h->writable_elements != h->elements)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array");
- esize = scm_array_handle_uniform_element_size (h);
- ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
- return ret;
+ return (void *) scm_array_handle_uniform_elements (h);
}
void
diff --git a/libguile/vectors.c b/libguile/vectors.c
index b9613c5..328cf6f 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -42,6 +42,12 @@
#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
scm_is_vector (SCM obj)
{
@@ -58,14 +64,6 @@ const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
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 */
if (SCM_I_WVECTP (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
@@ -77,7 +75,19 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
*lenp = dim->ubnd - dim->lbnd + 1;
*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,
@@ -203,7 +213,7 @@ void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
#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))
scm_out_of_range (NULL, scm_from_size_t (k));
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 995f64f..d279787 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -63,6 +63,14 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
/* 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_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index cb7d4aa..6c88ebf 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -420,6 +420,8 @@
VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box)
#define VM_VALIDATE_BYTEVECTOR(x, proc) \
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) \
VM_VALIDATE (x, SCM_CHARP, proc, char)
#define VM_VALIDATE_PAIR(x, proc) \
@@ -434,6 +436,8 @@
VM_VALIDATE (obj, SCM_VARIABLEP, proc, variable)
#define VM_VALIDATE_VECTOR(obj, proc) \
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) \
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);
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!");
SCM_I_VECTOR_WELTS (vect)[c_idx] = val;
NEXT (1);
@@ -2710,7 +2714,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
vect = SP_REF (dst);
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!");
SCM_I_VECTOR_WELTS (vect)[idx] = val;
NEXT (1);
@@ -3044,7 +3048,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
c_idx = SP_REF_U64 (idx); \
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 \
&& 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); \
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 \
&& SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \
diff --git a/libguile/vm.c b/libguile/vm.c
index ea2bfbd..18f2192 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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_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_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_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_int64 (const char *subr, scm_t_int64 idx)
SCM_NORETURN SCM_NOINLINE;
static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
@@ -553,6 +555,12 @@ vm_error_not_a_bytevector (const char *subr, SCM x)
}
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
vm_error_not_a_struct (const char *subr, SCM x)
{
scm_wrong_type_arg_msg (subr, 1, x, "struct");
@@ -565,6 +573,12 @@ vm_error_not_a_vector (const char *subr, SCM x)
}
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
vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx)
{
scm_out_of_range (subr, scm_from_uint64 (idx));
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 56c33be..cfccd5b 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1392,17 +1392,27 @@ should be .data or .rodata), and return the resulting
linker object.
(+ address
(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 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-program 69)
- (define tc7-bytevector 77)
- (define tc7-bitvector 95)
- (define tc7-array 93)
+
+ (define tc7-program #x45)
+
+ (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))
(endianness (asm-endianness asm)))
@@ -1447,9 +1457,10 @@ should be .data or .rodata), and return the resulting
linker object.
((stringbuf? obj)
(let* ((x (stringbuf-string obj))
(len (string-length x))
- (tag (if (= (string-bytes-per-char x) 1)
- tc7-narrow-stringbuf
- tc7-wide-stringbuf)))
+ (tag (logior tc7-stringbuf
+ (if (= (string-bytes-per-char x) 1)
+ 0
+ stringbuf-wide-flag))))
(case word-size
((4)
(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))
((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
((4)
- (bytevector-u32-set! buf pos tc7-ro-string endianness)
+ (bytevector-u32-set! buf pos tag endianness)
(write-placeholder asm buf (+ pos 4)) ; stringbuf
(bytevector-u32-set! buf (+ pos 8) 0 endianness)
(bytevector-u32-set! buf (+ pos 12) (string-length obj)
endianness))
((8)
- (bytevector-u64-set! buf pos tc7-ro-string endianness)
+ (bytevector-u64-set! buf pos tag endianness)
(write-placeholder asm buf (+ pos 8)) ; stringbuf
(bytevector-u64-set! buf (+ pos 16) 0 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)
(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
((4) (bytevector-u32-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)
(let ((tag (if (bitvector? obj)
- tc7-bitvector
- (let ((type-code (array-type-code obj)))
- (logior tc7-bytevector (ash type-code 7))))))
+ (logior tc7-bitvector
+ bitvector-immutable-flag)
+ (logior tc7-bytevector
+ ;; Bytevector immutable flag also shifted
+ ;; left.
+ (ash (logior bytevector-immutable-flag
+ (array-type-code obj))
+ 7)))))
(case word-size
((4)
(bytevector-u32-set! buf pos tag endianness)