From 9ff7c0651c0d357d2a2eccbcf88f045272a1e852 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 3 Jun 2025 14:50:54 +0200 Subject: [PATCH] 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 | 293 +++++++++++++++++---------------- libguile/arrays.h | 26 +-- libguile/init.c | 2 +- libguile/print.c | 2 +- module/system/vm/assembler.scm | 2 +- 8 files changed, 248 insertions(+), 178 deletions(-) create mode 100644 libguile/arrays-internal.h 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 #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 + . */ + + + +#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 #include +#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 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 #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!))