diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 39b52f872..a51a0dead 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -531,6 +531,7 @@ noinst_HEADERS = atomic.h \
strings-internal.h \
syntax.h \
trace.h \
+ vectors-internal.h \
whippet-embedder.h
# vm instructions
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 3da246a14..2fe3c707e 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -37,7 +37,7 @@
#include "pairs.h"
#include "strings-internal.h"
#include "symbols.h"
-#include "vectors.h"
+#include "vectors-internal.h"
#include "array-handle.h"
@@ -202,8 +202,8 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
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_IS_MUTABLE_VECTOR (array));
+ scm_i_vector_slots (scm_to_vector (array)),
+ scm_is_mutable_vector (array));
break;
case scm_tc7_bitvector:
initialize_vector_handle (h, scm_c_bitvector_length (array),
diff --git a/libguile/eq.c b/libguile/eq.c
index 73bb73795..1566a9804 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -44,7 +44,7 @@
#include "strorder.h"
#include "struct.h"
#include "syntax.h"
-#include "vectors.h"
+#include "vectors-internal.h"
#include "eq.h"
diff --git a/libguile/init.c b/libguile/init.c
index a6ebe4f65..2f7f9b3e7 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -138,7 +138,7 @@
#include "uniform.h"
#include "values.h"
#include "variable.h"
-#include "vectors.h"
+#include "vectors-internal.h"
#include "version.h"
#include "vm.h"
diff --git a/libguile/vectors-internal.h b/libguile/vectors-internal.h
new file mode 100644
index 000000000..361afcafd
--- /dev/null
+++ b/libguile/vectors-internal.h
@@ -0,0 +1,93 @@
+#ifndef SCM_VECTORS_INTERNAL_H
+#define SCM_VECTORS_INTERNAL_H
+
+/* Copyright 1995-1996,1998,2000-2002,2004-2006,2008-2009,2011,2014,2018,2025
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile is free software: you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as published
+ by the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ Guile is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with Guile. If not, see
+ . */
+
+
+
+#include "libguile/vectors.h"
+
+
+
+#define SCM_F_VECTOR_IMMUTABLE 0x80UL
+
+struct scm_vector
+{
+ scm_t_bits tag_and_size;
+ SCM slots[];
+};
+
+static inline int
+scm_is_mutable_vector (SCM x)
+{
+ return SCM_NIMP (x) &&
+ (SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) == scm_tc7_vector;
+}
+
+static inline struct scm_vector *
+scm_to_vector (SCM v)
+{
+ if (!scm_is_vector (v))
+ abort ();
+ return (struct scm_vector *) SCM_UNPACK_POINTER (v);
+}
+
+static inline SCM
+scm_from_vector (struct scm_vector *v)
+{
+ return SCM_PACK_POINTER (v);
+}
+
+static inline size_t
+scm_i_vector_length (struct scm_vector *v)
+{
+ return v->tag_and_size >> 8;
+}
+
+static inline SCM*
+scm_i_vector_slots (struct scm_vector *v)
+{
+ return v->slots;
+}
+
+static inline SCM*
+scm_i_vector_slot (struct scm_vector *v, size_t idx)
+{
+ if (idx >= scm_i_vector_length (v))
+ abort ();
+ return &scm_i_vector_slots (v)[idx];
+}
+
+static inline SCM
+scm_i_vector_ref (struct scm_vector *v, size_t idx)
+{
+ return *scm_i_vector_slot (v, idx);
+}
+
+static inline void
+scm_i_vector_set_x (struct scm_vector *v, size_t idx, SCM val)
+{
+ *scm_i_vector_slot (v, idx) = val;
+}
+
+SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
+SCM_INTERNAL void scm_init_vectors (void);
+
+#endif /* SCM_VECTORS_INTERNAL_H */
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 917f47a6b..5a1480cb8 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -35,7 +35,8 @@
#include "list.h"
#include "numbers.h"
#include "pairs.h"
-#include "vectors.h"
+#include "threads.h"
+#include "vectors-internal.h"
@@ -43,7 +44,7 @@
#define SCM_VALIDATE_MUTABLE_VECTOR(pos, v) \
do { \
- SCM_ASSERT_TYPE (SCM_I_IS_MUTABLE_VECTOR (v), v, pos, FUNC_NAME, \
+ SCM_ASSERT_TYPE (scm_is_mutable_vector (v), v, pos, FUNC_NAME, \
"mutable vector"); \
} while (0)
@@ -105,7 +106,7 @@ scm_c_vector_length (SCM v)
{
SCM_VALIDATE_VECTOR (1, v);
- return SCM_I_VECTOR_LENGTH (v);
+ return scm_i_vector_length (scm_to_vector (v));
}
#undef FUNC_NAME
@@ -136,7 +137,7 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
SCM_VALIDATE_LIST_COPYLEN (1, l, len);
res = scm_c_make_vector (len, SCM_UNSPECIFIED);
- data = SCM_I_VECTOR_WELTS (res);
+ data = scm_i_vector_slots (scm_to_vector (res));
i = 0;
while (scm_is_pair (l) && i < len)
{
@@ -173,11 +174,12 @@ scm_c_vector_ref (SCM v, size_t k)
#define FUNC_NAME s_scm_vector_ref
{
SCM_VALIDATE_VECTOR (1, v);
+ struct scm_vector *vv = scm_to_vector (v);
- if (k >= SCM_I_VECTOR_LENGTH (v))
+ if (k >= scm_i_vector_length (vv))
scm_out_of_range (NULL, scm_from_size_t (k));
- return SCM_I_VECTOR_ELTS (v)[k];
+ return scm_i_vector_ref (vv, k);
}
#undef FUNC_NAME
@@ -204,11 +206,12 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
#define FUNC_NAME s_scm_vector_set_x
{
SCM_VALIDATE_MUTABLE_VECTOR (1, v);
+ struct scm_vector *vv = scm_to_vector (v);
- if (k >= SCM_I_VECTOR_LENGTH (v))
+ if (k >= scm_i_vector_length (vv))
scm_out_of_range (NULL, scm_from_size_t (k));
- SCM_I_VECTOR_WELTS (v)[k] = obj;
+ scm_i_vector_set_x (vv, k, obj);
}
#undef FUNC_NAME
@@ -229,26 +232,27 @@ SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
}
#undef FUNC_NAME
-static SCM
+static struct scm_vector *
make_vector (size_t size)
{
- return scm_words ((size << 8) | scm_tc7_vector, size + 1);
+ struct scm_vector *ret =
+ scm_allocate_tagged (SCM_I_CURRENT_THREAD,
+ sizeof (*ret) + size * sizeof (SCM));
+ ret->tag_and_size = (size << 8) | scm_tc7_vector;
+ return ret;
}
SCM
scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
- SCM vector;
-
SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
- vector = make_vector (k);
- SCM *slots = SCM_I_VECTOR_WELTS (vector);
+ struct scm_vector *vector = make_vector (k);
for (size_t i = 0; i < k; ++i)
- slots[i] = fill;
+ scm_i_vector_set_x (vector, i, fill);
- return vector;
+ return scm_from_vector (vector);
}
#undef FUNC_NAME
@@ -260,10 +264,9 @@ SCM_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0,
"length of @var{vec}.")
#define FUNC_NAME s_scm_vector_copy_partial
{
- SCM result;
-
SCM_VALIDATE_VECTOR (1, vec);
- size_t cstart = 0, cend = SCM_I_VECTOR_LENGTH (vec);
+ struct scm_vector *src = scm_to_vector (vec);
+ size_t cstart = 0, cend = scm_i_vector_length (src);
if (!SCM_UNBNDP (start))
{
@@ -278,11 +281,11 @@ SCM_DEFINE (scm_vector_copy_partial, "vector-copy", 1, 2, 0,
}
}
- size_t len = cend-cstart;
- result = make_vector (len);
- memcpy (SCM_I_VECTOR_WELTS (result), SCM_I_VECTOR_ELTS (vec) + cstart,
+ size_t len = cend - cstart;
+ struct scm_vector *dst = make_vector (len);
+ memcpy (scm_i_vector_slots (dst), scm_i_vector_slots (src) + cstart,
len * sizeof(SCM));
- return result;
+ return scm_from_vector (dst);
}
#undef FUNC_NAME
@@ -306,10 +309,12 @@ SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0,
{
SCM_VALIDATE_MUTABLE_VECTOR (1, dst);
SCM_VALIDATE_VECTOR (3, src);
+ struct scm_vector *vdst = scm_to_vector (dst);
+ struct scm_vector *vsrc = scm_to_vector (src);
size_t src_org = 0;
size_t dst_org = scm_to_size_t (at);
- size_t src_end = SCM_I_VECTOR_LENGTH (src);
- size_t dst_end = SCM_I_VECTOR_LENGTH (dst);
+ size_t src_end = scm_i_vector_length (vsrc);
+ size_t dst_end = scm_i_vector_length (vdst);
if (!SCM_UNBNDP (start))
{
@@ -326,7 +331,8 @@ SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0,
size_t len = src_end-src_org;
SCM_ASSERT_RANGE (SCM_ARG2, at, dst_org<=dst_end && len<=dst_end-dst_org);
- memmove (SCM_I_VECTOR_WELTS (dst) + dst_org, SCM_I_VECTOR_ELTS (src) + src_org,
+ memmove (scm_i_vector_slots (vdst) + dst_org,
+ scm_i_vector_slots (vsrc) + src_org,
len * sizeof(SCM));
return SCM_UNSPECIFIED;
@@ -347,11 +353,11 @@ SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
SCM res = SCM_EOL;
SCM_VALIDATE_VECTOR (1, vec);
+ struct scm_vector *v = scm_to_vector (vec);
- ssize_t len = SCM_I_VECTOR_LENGTH (vec);
- const SCM * data = SCM_I_VECTOR_ELTS (vec);
+ ssize_t len = scm_i_vector_length (v);
for (ssize_t i = len-1; i >= 0; --i)
- res = scm_cons (data[i], res);
+ res = scm_cons (scm_i_vector_ref (v, i), res);
return res;
}
@@ -367,11 +373,12 @@ SCM_DEFINE_STATIC (scm_vector_fill_partial_x, "vector-fill!", 2, 2, 0,
"returned by @code{vector-fill!} is unspecified.")
#define FUNC_NAME s_scm_vector_fill_partial_x
{
- SCM_VALIDATE_MUTABLE_VECTOR(1, vec);
+ SCM_VALIDATE_MUTABLE_VECTOR (1, vec);
+ struct scm_vector *v = scm_to_vector (vec);
size_t i = 0;
- size_t c_end = SCM_I_VECTOR_LENGTH (vec);
- SCM *data = SCM_I_VECTOR_WELTS (vec);
+ size_t c_end = scm_i_vector_length (v);
+ SCM *data = scm_i_vector_slots (v);
if (!SCM_UNBNDP (start))
i = scm_to_unsigned_integer (start, 0, c_end);
@@ -399,9 +406,11 @@ SCM
scm_i_vector_equal_p (SCM x, SCM y)
{
long i;
- for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
- if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
- SCM_I_VECTOR_ELTS (y)[i])))
+ struct scm_vector *vx = scm_to_vector (x);
+ struct scm_vector *vy = scm_to_vector (y);
+ for (i = scm_i_vector_length (vx) - 1; i >= 0; i--)
+ if (scm_is_false (scm_equal_p (scm_i_vector_ref (vx, i),
+ scm_i_vector_ref (vy, i))))
return SCM_BOOL_F;
return SCM_BOOL_T;
}
@@ -419,13 +428,14 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
#define FUNC_NAME s_scm_vector_move_left_x
{
SCM_VALIDATE_VECTOR (1, vec1);
- SCM_VALIDATE_VECTOR (4, vec2);
+ SCM_VALIDATE_MUTABLE_VECTOR (4, vec2);
+ struct scm_vector *v1 = scm_to_vector (vec1);
+ struct scm_vector *v2 = scm_to_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);
+ const SCM *elts1 = scm_i_vector_slots (v1);
+ SCM *elts2 = scm_i_vector_slots (v2);
+ size_t len1 = scm_i_vector_length (v1);
+ size_t len2 = scm_i_vector_length (v2);
size_t i, j, e;
i = scm_to_unsigned_integer (start1, 0, len1);
@@ -452,13 +462,14 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
#define FUNC_NAME s_scm_vector_move_right_x
{
SCM_VALIDATE_VECTOR (1, vec1);
- SCM_VALIDATE_VECTOR (4, vec2);
+ SCM_VALIDATE_MUTABLE_VECTOR (4, vec2);
+ struct scm_vector *v1 = scm_to_vector (vec1);
+ struct scm_vector *v2 = scm_to_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);
+ const SCM *elts1 = scm_i_vector_slots (v1);
+ SCM *elts2 = scm_i_vector_slots (v2);
+ size_t len1 = scm_i_vector_length (v1);
+ size_t len2 = scm_i_vector_length (v2);
size_t i, j, e;
i = scm_to_unsigned_integer (start1, 0, len1);
diff --git a/libguile/vectors.h b/libguile/vectors.h
index f4385fc3d..425eb2831 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -1,7 +1,7 @@
#ifndef SCM_VECTORS_H
#define SCM_VECTORS_H
-/* Copyright 1995-1996,1998,2000-2002,2004-2006,2008-2009,2011,2014,2018
+/* Copyright 1995-1996,1998,2000-2002,2004-2006,2008-2009,2011,2014,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -24,14 +24,15 @@
#include "libguile/array-handle.h"
#include
-#include "libguile/gc.h"
+#define SCM_F_VECTOR_IMMUTABLE 0x80UL
+
static inline int
-scm_is_vector (SCM obj)
+scm_is_vector (SCM x)
{
- return SCM_HAS_TYP7 (obj, scm_tc7_vector);
+ return SCM_HAS_TYP7 (x, scm_tc7_vector);
}
SCM_API SCM scm_vector_p (SCM x);
@@ -71,22 +72,5 @@ SCM_API SCM *scm_vector_writable_elements (SCM array,
SCM_ASSERT (scm_is_vector (v) && len == scm_c_vector_length (v), v, pos, FUNC_NAME); \
} while (0)
-
-/* 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_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_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
-
-SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
-SCM_INTERNAL void scm_init_vectors (void);
#endif /* SCM_VECTORS_H */