mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Give arrays a proper type in C land

Browse source 
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!
This commit is contained in:
Andy Wingo 2025-06-03 14:50:54 +02:00
parent 12e8772403
commit 9ff7c0651c
8 changed files with 248 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/Makefile.am
View file

@ -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 \

14
libguile/array-handle.c
View file

@ -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");

86
libguile/arrays-internal.h Normal file
View file

@ -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 */

293
libguile/arrays.c
View file

@ -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--;)
{
SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
}
for (k = SCM_I_ARRAY_NDIM (ra); k--;)
{
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)
{
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;
}
}
if (ndim > 0)
SCM_MISC_ERROR ("bad argument list", SCM_EOL);
return res;
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)
{
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)
{
res->base += (s->lbnd - r->lbnd) * r->inc;
r->lbnd = s->lbnd;
}
r->inc += s->inc;
}
}
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

26
libguile/arrays.h
View file

@ -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 */

2
libguile/init.c
View file

@ -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"

2
libguile/print.c
View file

@ -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"

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

@ -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!))