wingo pushed a commit to branch wip-whippet
in repository guile.
commit 9ff7c0651c0d357d2a2eccbcf88f045272a1e852
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Jun 3 14:50:54 2025 +0200
Give arrays a proper type in C land
As long as we have a tc7 for arrays, we should be able to access it with
a struct type instead of casting each word.
* libguile/arrays-internal.h: New file.
* libguile/arrays.h (scm_array_p): Take just one argument.
(SCM_I_ARRAYP):
(SCM_I_ARRAY_NDIM):
(SCM_I_ARRAY_V):
(SCM_I_ARRAY_BASE):
(SCM_I_ARRAY_DIMS):
(SCM_I_ARRAY_SET_V):
(SCM_I_ARRAY_SET_BASE): Remove.
(scm_i_raw_array, scm_i_make_array, scm_i_shap2ra, scm_init_arrays):
Remove internally-linked decls.
* libguile/init.c:
* libguile/print.c:
* libguile/array-handle.c: Use interfaces from new file.
* module/system/vm/assembler.scm: Update, as we now shift the dimension
count by only 16. Requires a rebuild!
---
libguile/Makefile.am | 1 +
libguile/array-handle.c | 14 ++-
libguile/arrays-internal.h | 86 +++++++++++++
libguile/arrays.c | 279 +++++++++++++++++++++--------------------
libguile/arrays.h | 26 +---
libguile/init.c | 2 +-
libguile/print.c | 2 +-
module/system/vm/assembler.scm | 2 +-
8 files changed, 241 insertions(+), 171 deletions(-)
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 5b3cb0740..c3d1b8138 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -522,6 +522,7 @@ noinst_HEADERS = custom-ports.h
\
intrinsics.h \
quicksort.i.c \
atomics-internal.h \
+ arrays-internal.h \
bytevectors-internal.h \
cache-internal.h \
gc-inline.h \
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index 37eaab688..5acbb743e 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -27,6 +27,7 @@
#include <string.h>
#include "arrays.h"
+#include "arrays-internal.h"
#include "boolean.h"
#include "bitvectors.h"
#include "bytevectors.h"
@@ -260,11 +261,14 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
}
break;
case scm_tc7_array:
- scm_array_get_handle (SCM_I_ARRAY_V (array), h);
- h->array = array;
- h->base = SCM_I_ARRAY_BASE (array);
- h->ndims = SCM_I_ARRAY_NDIM (array);
- h->dims = SCM_I_ARRAY_DIMS (array);
+ {
+ struct scm_array *ra = scm_to_array (array);
+ scm_array_get_handle (scm_array_vector (ra), h);
+ h->array = array;
+ h->base = scm_array_base (ra);
+ h->ndims = scm_array_dimension_count (ra);
+ h->dims = ra->dims;
+ }
break;
default:
scm_wrong_type_arg_msg (NULL, 0, array, "array");
diff --git a/libguile/arrays-internal.h b/libguile/arrays-internal.h
new file mode 100644
index 000000000..fe9dee453
--- /dev/null
+++ b/libguile/arrays-internal.h
@@ -0,0 +1,86 @@
+#ifndef SCM_ARRAYS_INTERNAL_H
+#define SCM_ARRAYS_INTERNAL_H
+
+/* Copyright 1995-1997,1999-2001,2004,2006,2008-2010,2012,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
+ <https://www.gnu.org/licenses/>. */
+
+
+
+#include "libguile/arrays.h"
+
+
+
+struct scm_array
+{
+ scm_t_bits tag_and_ndims;
+ SCM vector;
+ size_t base;
+ struct scm_t_array_dim dims[];
+};
+
+/* There is a naming confusion: scm_is_array exists and is used for
+ generalized arrays, allowing e.g. (array? #(1 2 3)) to be true. Here
+ we are concerned with proper multidimensional arrays, which are their
+ own data type. Mostly we can use this "struct scm_array" as a way to
+ avoid confusion, but we have to name this function
+ "scm_is_tagged_array" instead of "scm_is_array" as we would like. */
+static inline int
+scm_is_tagged_array (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_array);
+}
+
+static inline struct scm_array*
+scm_to_array (SCM x)
+{
+ if (!scm_is_tagged_array (x))
+ abort ();
+ return (struct scm_array *) SCM_UNPACK_POINTER (x);
+}
+
+static inline SCM
+scm_from_array (struct scm_array *x)
+{
+ return SCM_PACK_POINTER (x);
+}
+
+static inline size_t
+scm_array_dimension_count (struct scm_array *array)
+{
+ return array->tag_and_ndims >> 16;
+}
+
+static inline SCM
+scm_array_vector (struct scm_array *array)
+{
+ return array->vector;
+}
+
+static inline size_t
+scm_array_base (struct scm_array *array)
+{
+ return array->base;
+}
+
+SCM_INTERNAL struct scm_array* scm_i_make_array (SCM v, size_t base, int ndim);
+SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate);
+
+SCM_INTERNAL void scm_init_arrays (void);
+
+#endif /* SCM_ARRAYS_INTERNAL_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 46ac7bfc8..fb65c8f5b 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,6 +28,7 @@
#include <errno.h>
#include <string.h>
+#include "arrays-internal.h"
#include "bitvectors.h"
#include "boolean.h"
#include "chars.h"
@@ -53,8 +54,6 @@
#include "variable.h"
#include "vectors.h"
-#include "arrays.h"
-
SCM_INTERNAL SCM scm_i_array_ref (SCM v,
SCM idx0, SCM idx1, SCM idxN);
SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
@@ -80,26 +79,16 @@ scm_is_array (SCM obj)
}
}
-SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
+SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
"not.")
-#define FUNC_NAME s_scm_array_p_2
+#define FUNC_NAME s_scm_array_p
{
return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME
-/* The array type predicate, with an extra argument kept for backward
- compatibility. Note that we can't use `SCM_DEFINE' directly because there
- would be an argument count mismatch that would be caught by
- `snarf-check-and-output-texi.scm'. */
-SCM
-scm_array_p (SCM obj, SCM unused)
-{
- return scm_array_p_2 (obj);
-}
-
int
scm_is_typed_array (SCM obj, SCM type)
{
@@ -423,8 +412,8 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
size_t
scm_c_array_rank (SCM array)
{
- if (SCM_I_ARRAYP (array))
- return SCM_I_ARRAY_NDIM (array);
+ if (scm_is_tagged_array (array))
+ return scm_array_dimension_count (scm_to_array (array));
else if (scm_is_array (array))
return 1;
else
@@ -446,8 +435,8 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1,
0, 0,
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
- if (SCM_I_ARRAYP (ra))
- return SCM_I_ARRAY_V (ra);
+ if (scm_is_tagged_array (ra))
+ return scm_array_vector (scm_to_array (ra));
else if (scm_is_array (ra))
return ra;
else
@@ -461,8 +450,8 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset",
1, 0, 0,
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
{
- if (SCM_I_ARRAYP (ra))
- return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+ if (scm_is_tagged_array (ra))
+ return scm_from_size_t (scm_array_base (scm_to_array (ra)));
else if (scm_is_array (ra))
return scm_from_size_t (0);
else
@@ -476,11 +465,12 @@ SCM_DEFINE (scm_shared_array_increments,
"shared-array-increments", 1, 0, 0,
"For each dimension, return the distance between elements in the
root vector.")
#define FUNC_NAME s_scm_shared_array_increments
{
- if (SCM_I_ARRAYP (ra))
+ if (scm_is_tagged_array (ra))
{
- size_t k = SCM_I_ARRAY_NDIM (ra);
+ struct scm_array *array = scm_to_array (ra);
+ size_t k = scm_array_dimension_count (array);
SCM res = SCM_EOL;
- scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+ scm_t_array_dim *dims = array->dims;
while (k--)
res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
return res;
@@ -493,30 +483,33 @@ SCM_DEFINE (scm_shared_array_increments,
"shared-array-increments", 1, 0, 0,
#undef FUNC_NAME
-SCM
-scm_i_make_array (int ndim)
+struct scm_array *
+scm_i_make_array (SCM v, size_t base, int ndim)
{
- SCM ra = scm_i_raw_array (ndim);
- SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
- SCM_I_ARRAY_SET_BASE (ra, 0);
- /* dimensions are unset */
- return ra;
+ struct scm_array *array = scm_gc_malloc (sizeof (struct scm_array)
+ + ndim * sizeof (scm_t_array_dim),
+ "array");
+ /* FIXME: Shift ndim by something more reasonable instead. */
+ array->tag_and_ndims = scm_tc7_array | (ndim << 16);
+ array->vector = v;
+ array->base = base;
+ /* Dimensions need initialization; they are initially zero. */
+ return array;
}
/* Increments will still need to be set. */
-SCM
+static struct scm_array *
scm_i_shap2ra (SCM args)
{
- scm_t_array_dim *s;
int ndim = scm_ilength (args);
if (ndim < 0)
scm_misc_error (NULL, "bad array bounds ~a", scm_list_1 (args));
- SCM ra = scm_i_make_array (ndim);
- SCM_I_ARRAY_SET_BASE (ra, 0);
- s = SCM_I_ARRAY_DIMS (ra);
- for (; !scm_is_null (args); s++, args = SCM_CDR (args))
+ struct scm_array *array = scm_i_make_array (SCM_BOOL_F, 0, ndim);
+ for (scm_t_array_dim *s = array->dims;
+ !scm_is_null (args);
+ s++, args = SCM_CDR (args))
{
SCM spec = SCM_CAR (args);
if (scm_is_integer (spec))
@@ -543,7 +536,7 @@ scm_i_shap2ra (SCM args)
}
s->inc = 1;
}
- return ra;
+ return array;
}
SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
@@ -553,11 +546,10 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2,
0, 1,
{
size_t k, rlen = 1;
scm_t_array_dim *s;
- SCM ra;
- ra = scm_i_shap2ra (bounds);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
+ struct scm_array *ra = scm_i_shap2ra (bounds);
+ s = ra->dims;
+ k = scm_array_dimension_count (ra);
while (k--)
{
@@ -569,13 +561,13 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2,
0, 1,
if (scm_is_eq (fill, SCM_UNSPECIFIED))
fill = SCM_UNDEFINED;
- SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t
(rlen), fill));
+ ra->vector = scm_make_generalized_vector (type, scm_from_size_t (rlen),
fill);
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (0 == s->lbnd)
- return SCM_I_ARRAY_V (ra);
+ if (1 == scm_array_dimension_count (ra) && 0 == scm_array_base (ra)
+ && 0 == s->lbnd)
+ return ra->vector;
- return ra;
+ return scm_from_array (ra);
}
#undef FUNC_NAME
@@ -611,7 +603,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2,
0, 1,
#define FUNC_NAME s_scm_make_shared_array
{
scm_t_array_handle old_handle;
- SCM ra;
SCM inds, indptr;
SCM imap;
size_t k;
@@ -621,14 +612,15 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array",
2, 0, 1,
SCM_VALIDATE_REST_ARGUMENT (dims);
SCM_VALIDATE_PROC (2, mapfunc);
- ra = scm_i_shap2ra (dims);
+ struct scm_array *ra = scm_i_shap2ra (dims);
scm_array_get_handle (oldra, &old_handle);
- if (SCM_I_ARRAYP (oldra))
+ if (scm_is_tagged_array (oldra))
{
- SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
- old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
+ struct scm_array *old = scm_to_array (oldra);
+ ra->vector = old->vector;
+ old_base = old_min = old_max = old->base;
s = scm_array_handle_dims (&old_handle);
k = scm_array_handle_rank (&old_handle);
while (k--)
@@ -641,35 +633,40 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array",
2, 0, 1,
}
else
{
- SCM_I_ARRAY_SET_V (ra, oldra);
+ ra->vector = oldra;
old_base = old_min = 0;
old_max = scm_c_array_length (oldra) - 1;
}
inds = SCM_EOL;
- s = SCM_I_ARRAY_DIMS (ra);
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ s = ra->dims;
+ for (k = 0; k < scm_array_dimension_count (ra); k++)
{
inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds);
if (s[k].ubnd < s[k].lbnd)
{
- if (1 == SCM_I_ARRAY_NDIM (ra))
- ra = scm_make_generalized_vector (scm_array_type (ra),
- SCM_INUM0, SCM_UNDEFINED);
+ SCM ret;
+ if (1 == scm_array_dimension_count (ra))
+ ret = scm_make_generalized_vector (scm_array_type (scm_from_array
(ra)),
+ SCM_INUM0, SCM_UNDEFINED);
else
- SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type
(ra),
- SCM_INUM0,
SCM_UNDEFINED));
+ {
+ ret = scm_from_array (ra);
+ ra->vector =
+ scm_make_generalized_vector (scm_array_type (ret),
+ SCM_INUM0, SCM_UNDEFINED);
+ }
scm_array_handle_release (&old_handle);
- return ra;
+ return ret;
}
}
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
i = scm_array_handle_pos (&old_handle, imap);
new_min = new_max = i + old_base;
- SCM_I_ARRAY_SET_BASE (ra, new_min);
+ ra->base = new_min;
indptr = inds;
- k = SCM_I_ARRAY_NDIM (ra);
+ k = scm_array_dimension_count (ra);
while (k--)
{
if (s[k].ubnd > s[k].lbnd)
@@ -692,17 +689,17 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array",
2, 0, 1,
if (old_min > new_min || old_max < new_max)
scm_misc_error (FUNC_NAME, "mapping out of range", SCM_EOL);
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ if (1 == scm_array_dimension_count (ra) && 0 == scm_array_base (ra))
{
- SCM v = SCM_I_ARRAY_V (ra);
+ SCM v = scm_array_vector (ra);
size_t length = scm_c_array_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
- return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
- SCM_UNDEFINED);
+ return scm_make_generalized_vector (scm_array_type (scm_from_array
(ra)),
+ SCM_INUM0, SCM_UNDEFINED);
}
- return ra;
+ return scm_from_array (ra);
}
#undef FUNC_NAME
@@ -733,16 +730,17 @@ array_from_get_o (scm_t_array_handle *handle, size_t k,
scm_t_array_dim *s, ssiz
*o = handle->array;
else
{
- *o = scm_i_make_array (k);
- SCM_I_ARRAY_SET_V (*o, handle->vector);
- SCM_I_ARRAY_SET_BASE (*o, pos + handle->base);
- scm_t_array_dim * os = SCM_I_ARRAY_DIMS (*o);
- for (; k>0; --k, ++s, ++os)
+ struct scm_array *array =
+ scm_i_make_array (handle->vector, pos + handle->base, k);
+ for (scm_t_array_dim *os = array->dims;
+ k > 0;
+ --k, ++s, ++os)
{
os->ubnd = s->ubnd;
os->lbnd = s->lbnd;
os->inc = s->inc;
}
+ *o = scm_from_array (array);
}
}
@@ -770,7 +768,8 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
if (!s)
{
scm_array_handle_release (&handle);
- scm_misc_error (FUNC_NAME, "indices ~a out of range for array bounds
~a", scm_list_2 (indices, scm_array_dimensions (ra)));
+ scm_misc_error (FUNC_NAME, "indices ~a out of range for array bounds ~a",
+ scm_list_2 (indices, scm_array_dimensions (ra)));
}
SCM o;
if (scm_is_null (i))
@@ -788,7 +787,7 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
- (SCM ra, SCM args),
+ (SCM array, SCM args),
"Return an array sharing contents with @var{ra}, but with\n"
"dimensions arranged in a different order. There must be one\n"
"@var{dim} argument for each dimension of @var{ra}.\n"
@@ -810,19 +809,17 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0,
1,
"@end lisp")
#define FUNC_NAME s_scm_transpose_array
{
- SCM res, vargs;
scm_t_array_dim *s, *r;
int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
- switch (scm_c_array_rank (ra))
+ switch (scm_c_array_rank (array))
{
case 0:
if (!scm_is_null (args))
SCM_WRONG_NUM_ARGS ();
- return ra;
+ return array;
case 1:
/* Make sure that we are called with a single zero as
arguments.
@@ -831,56 +828,62 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0,
1,
SCM_WRONG_NUM_ARGS ();
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
- return ra;
+ return array;
default:
- vargs = scm_vector (args);
- if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
- SCM_WRONG_NUM_ARGS ();
- ndim = 0;
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- {
- i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
- 0, SCM_I_ARRAY_NDIM(ra));
- if (ndim < i)
- ndim = i;
- }
- ndim++;
- res = scm_i_make_array (ndim);
- SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
- SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
- for (k = ndim; k--;)
+ break;
+ }
+
+ SCM vargs = scm_vector (args);
+ struct scm_array *ra = scm_to_array (array);
+ if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != scm_array_dimension_count (ra))
+ SCM_WRONG_NUM_ARGS ();
+ ndim = 0;
+ for (k = 0; k < scm_array_dimension_count (ra); k++)
+ {
+ i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
+ 0, scm_array_dimension_count (ra));
+ if (ndim < i)
+ ndim = i;
+ }
+ ndim++;
+
+ struct scm_array *res = scm_i_make_array (ra->vector, ra->base, ndim);
+
+ for (k = ndim; k--;)
+ {
+ res->dims[k].lbnd = 0;
+ res->dims[k].ubnd = -1;
+ }
+
+ for (k = scm_array_dimension_count (ra); k--;)
+ {
+ i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
+ s = &(ra->dims[k]);
+ r = &(res->dims[i]);
+ if (r->ubnd < r->lbnd)
{
- SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
- SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
+ r->lbnd = s->lbnd;
+ r->ubnd = s->ubnd;
+ r->inc = s->inc;
+ ndim--;
}
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ else
{
- i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
- s = &(SCM_I_ARRAY_DIMS (ra)[k]);
- r = &(SCM_I_ARRAY_DIMS (res)[i]);
- if (r->ubnd < r->lbnd)
+ if (r->ubnd > s->ubnd)
+ r->ubnd = s->ubnd;
+ if (r->lbnd < s->lbnd)
{
+ res->base += (s->lbnd - r->lbnd) * r->inc;
r->lbnd = s->lbnd;
- r->ubnd = s->ubnd;
- r->inc = s->inc;
- ndim--;
- }
- else
- {
- if (r->ubnd > s->ubnd)
- r->ubnd = s->ubnd;
- if (r->lbnd < s->lbnd)
- {
- SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd
- r->lbnd) * r->inc);
- r->lbnd = s->lbnd;
- }
- r->inc += s->inc;
}
+ r->inc += s->inc;
}
- if (ndim > 0)
- SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- return res;
}
+
+ if (ndim > 0)
+ SCM_MISC_ERROR ("bad argument list", SCM_EOL);
+
+ return scm_from_array (res);
}
#undef FUNC_NAME
@@ -889,7 +892,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
/* if strict is true, return #f if returned array
wouldn't have contiguous elements. */
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
- (SCM ra, SCM strict),
+ (SCM array, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
"array without changing their order (last subscript changing\n"
"fastest), then @code{array-contents} returns that shared array,\n"
@@ -901,11 +904,12 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
"in memory.")
#define FUNC_NAME s_scm_array_contents
{
- if (SCM_I_ARRAYP (ra))
+ if (scm_is_tagged_array (array))
{
+ struct scm_array *ra = scm_to_array (array);
SCM v;
- size_t ndim = SCM_I_ARRAY_NDIM (ra);
- scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+ size_t ndim = scm_array_dimension_count (ra);
+ scm_t_array_dim *s = ra->dims;
size_t k = ndim;
size_t len = 1;
@@ -924,31 +928,30 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
{
if (ndim && (1 != s[ndim - 1].inc))
return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
- && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ if (scm_is_bitvector (scm_array_vector (ra))
+ && (len != scm_c_bitvector_length (scm_array_vector (ra)) ||
+ scm_array_base (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT))
return SCM_BOOL_F;
}
- v = SCM_I_ARRAY_V (ra);
- if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
+ v = scm_array_vector (ra);
+ if ((len == scm_c_array_length (v)) && (0 == scm_array_base (ra)))
return v;
else
{
- SCM sra = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_I_ARRAY_SET_V (sra, v);
- SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
- SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim -
1].inc : 1);
- return sra;
+ struct scm_array *sra = scm_i_make_array (v, scm_array_base (ra), 1);
+ sra->dims->lbnd = 0;
+ sra->dims->ubnd = len - 1;
+ sra->dims->inc =
+ (ndim ? ra->dims[ndim - 1].inc : 1);
+ return scm_from_array (sra);
}
}
- else if (scm_is_array (ra))
- return ra;
+ else if (scm_is_array (array))
+ return array;
else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
}
#undef FUNC_NAME
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 40e3ad7bd..d105ffbf4 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -58,8 +58,7 @@ SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_rank (SCM ra);
SCM_API int scm_is_array (SCM obj);
-SCM_API SCM scm_array_p (SCM v, SCM unused);
-SCM_INTERNAL SCM scm_array_p_2 (SCM);
+SCM_API SCM scm_array_p (SCM v);
SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
@@ -93,28 +92,5 @@ typedef struct scm_t_array_dim
ssize_t inc;
} scm_t_array_dim;
-/* internal. */
-
-#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
-#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
-#define SCM_I_ARRAY_V(a) SCM_CELL_OBJECT_1 (a)
-#define SCM_I_ARRAY_BASE(a) ((size_t) SCM_CELL_WORD_2 (a))
-#define SCM_I_ARRAY_DIMS(a) ((scm_t_array_dim *) SCM_CELL_OBJECT_LOC (a, 3))
-#define SCM_I_ARRAY_SET_V(a, v) SCM_SET_CELL_OBJECT_1(a, v)
-#define SCM_I_ARRAY_SET_BASE(a, base) SCM_SET_CELL_WORD_2(a, base)
-
-/* See the array cases in system/vm/assembler.scm. */
-
-static inline SCM
-scm_i_raw_array (int ndim)
-{
- return scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
-}
-
-SCM_INTERNAL SCM scm_i_make_array (int ndim);
-SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate);
-SCM_INTERNAL SCM scm_i_shap2ra (SCM args);
-
-SCM_INTERNAL void scm_init_arrays (void);
#endif /* SCM_ARRAYS_H */
diff --git a/libguile/init.c b/libguile/init.c
index c52de0c53..408e15334 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -41,7 +41,7 @@
/* Everybody has an init function. */
#include "alist.h"
-#include "arrays.h"
+#include "arrays-internal.h"
#include "async.h"
#include "atomic.h"
#include "backtrace.h"
diff --git a/libguile/print.c b/libguile/print.c
index db8996371..8721fbf43 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -31,7 +31,7 @@
#include <unictype.h>
#include "alist.h"
-#include "arrays.h"
+#include "arrays-internal.h"
#include "atomic.h"
#include "bitvectors.h"
#include "bytevectors-internal.h"
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 4157c95d7..1f341a2f7 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2068,7 +2068,7 @@ should be .data or .rodata), and return the resulting
linker object.
(let-values
;; array tag + rank
;; see libguile/arrays.h: SCM_I_ARRAY_NDIM, SCM_I_ARRAYP,
scm_i_raw_array
- (((tag) (logior tc7-array (ash (array-rank obj) 17)))
+ (((tag) (logior tc7-array (ash (array-rank obj) 16)))
((bv-set! bvs-set!)
(case word-size
((4) (values bytevector-u32-set! bytevector-s32-set!))
