mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
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!
This commit is contained in:
Andy Wingo
parent
12e8772403
commit
9ff7c0651c
8 changed files with 248 additions and 178 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
{
|
||||
struct scm_array *ra = scm_to_array (array);
|
||||
scm_array_get_handle (scm_array_vector (ra), 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);
|
||||
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
86
libguile/arrays-internal.h
Normal 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 */
|
||||
|
|
@ -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 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,33 +828,38 @@ 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))
|
||||
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_I_ARRAY_NDIM (ra); k++)
|
||||
for (k = 0; k < scm_array_dimension_count (ra); k++)
|
||||
{
|
||||
i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
|
||||
0, SCM_I_ARRAY_NDIM(ra));
|
||||
0, scm_array_dimension_count (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));
|
||||
|
||||
struct scm_array *res = scm_i_make_array (ra->vector, ra->base, ndim);
|
||||
|
||||
for (k = ndim; k--;)
|
||||
{
|
||||
SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
|
||||
SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
|
||||
res->dims[k].lbnd = 0;
|
||||
res->dims[k].ubnd = -1;
|
||||
}
|
||||
for (k = SCM_I_ARRAY_NDIM (ra); k--;)
|
||||
|
||||
for (k = scm_array_dimension_count (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]);
|
||||
s = &(ra->dims[k]);
|
||||
r = &(res->dims[i]);
|
||||
if (r->ubnd < r->lbnd)
|
||||
{
|
||||
r->lbnd = s->lbnd;
|
||||
|
|
@ -871,16 +873,17 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
|
|||
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);
|
||||
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 res;
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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!))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue