wingo pushed a commit to branch wip-whippet
in repository guile.
commit 12e8772403eae319070569375908a8312cb373d1
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Jun 3 13:17:35 2025 +0200
Move array-map / array-cell functions to Scheme module
* libguile/array-map.c:
* libguile/array-map.h: Remove.
* module/ice-9/deprecated.scm:
* libguile/deprecated.h:
* libguile/deprecated.c: Add deprecation shims.
* module/ice-9/arrays.scm: Move all array-map functionality here.
* libguile/Makefile.am:
* libguile/init.c:
* libguile.h: Remove array-map.h use.
* libguile/arrays.c (scm_i_array_equal_p, scm_i_array_copy): New
helpers.
(scm_array_cell_ref, scm_array_cell_set_x): Move to Scheme.
* libguile/arrays.h:
* libguile/eq.c (scm_equal_p):
* libguile/sort.c (scm_sort): Use new arrays.c helpers.
* module/ice-9/pretty-print.scm:
* module/oop/goops/save.scm: Import (ice-9 arrays).
---
libguile.h | 1 -
libguile/Makefile.am | 4 -
libguile/array-map.c | 921 ----------------------------------------
libguile/array-map.h | 44 --
libguile/arrays.c | 137 ++----
libguile/arrays.h | 8 +-
libguile/deprecated.c | 110 +++++
libguile/deprecated.h | 11 +
libguile/eq.c | 6 +-
libguile/init.c | 2 -
libguile/sort.c | 8 +-
module/ice-9/arrays.scm | 620 ++++++++++++++++++++++++++-
module/ice-9/deprecated.scm | 78 +++-
module/ice-9/pretty-print.scm | 3 +-
module/oop/goops/save.scm | 1 +
test-suite/tests/array-map.test | 5 +-
test-suite/tests/arrays.test | 5 +-
17 files changed, 867 insertions(+), 1097 deletions(-)
diff --git a/libguile.h b/libguile.h
index b5594a4d8..2b17052c2 100644
--- a/libguile.h
+++ b/libguile.h
@@ -30,7 +30,6 @@ extern "C" {
#include "libguile/alist.h"
#include "libguile/array-handle.h"
-#include "libguile/array-map.h"
#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/atomic.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ef1dc6970..5b3cb0740 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -134,7 +134,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_CFLAGS =
$(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =
\
alist.c \
array-handle.c \
- array-map.c \
arrays.c \
async.c \
atomic.c \
@@ -250,7 +249,6 @@ endif
DOT_X_FILES = \
alist.x \
array-handle.x \
- array-map.x \
arrays.x \
async.x \
atomic.x \
@@ -352,7 +350,6 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = \
alist.doc \
array-handle.doc \
- array-map.doc \
arrays.doc \
async.doc \
atomic.doc \
@@ -592,7 +589,6 @@ modinclude_HEADERS = \
__scm.h \
alist.h \
array-handle.h \
- array-map.h \
arrays.h \
async.h \
atomic.h \
diff --git a/libguile/array-map.c b/libguile/array-map.c
deleted file mode 100644
index ce0f7ba09..000000000
--- a/libguile/array-map.c
+++ /dev/null
@@ -1,921 +0,0 @@
-/* Copyright 1996,1998,2000-2001,2004-2006,2008-2015,2018-2019
- 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/>. */
-
-
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <assert.h>
-#include <string.h>
-
-#include "arrays.h"
-#include "bitvectors.h"
-#include "boolean.h"
-#include "chars.h"
-#include "eq.h"
-#include "eval.h"
-#include "feature.h"
-#include "gsubr.h"
-#include "list.h"
-#include "numbers.h"
-#include "pairs.h"
-#include "procs.h"
-#include "smob.h"
-#include "srfi-4.h"
-#include "strings.h"
-#include "symbols.h"
-#include "vectors.h"
-
-#include "array-map.h"
-
-
-/* The WHAT argument for `scm_gc_malloc ()' et al. */
-static const char vi_gc_hint[] = "array-indices";
-
-static SCM
-make1array (SCM v, ssize_t inc)
-{
- SCM a = scm_i_make_array (1);
- SCM_I_ARRAY_SET_BASE (a, 0);
- SCM_I_ARRAY_DIMS (a)->lbnd = 0;
- SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
- SCM_I_ARRAY_DIMS (a)->inc = inc;
- SCM_I_ARRAY_SET_V (a, v);
- return a;
-}
-
-/* Linear index of not-unrolled index set. */
-static size_t
-cindk (SCM ra, ssize_t *ve, int kend)
-{
- if (SCM_I_ARRAYP (ra))
- {
- int k;
- size_t i = SCM_I_ARRAY_BASE (ra);
- for (k = 0; k < kend; ++k)
- i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS
(ra)[k].inc;
- return i;
- }
- else
- return 0; /* this is BASE */
-}
-
-/* array mapper: apply cproc to each dimension of the given arrays?.
- int (*cproc) (); procedure to call on unrolled arrays?
- cproc (dest, source list) or
- cproc (dest, data, source list).
- SCM data; data to give to cproc or unbound.
- SCM ra0; destination array.
- SCM lra; list of source arrays.
- const char *what; caller, for error reporting. */
-
-#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
-#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
-#define MAX(A, B) ((A) >= (B) ? (A) : (B))
-
-
-/* scm_ramapc() always calls cproc with rank-1 arrays created by
- make1array. cproc (rafe, ramap, rafill, racp) can assume that the
- dims[0].lbnd of these arrays is always 0. */
-int
-scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
-{
- int (*cproc) () = cproc_ptr;
- SCM z, va0, lva, *plva;
- int k, kmax, kroll;
- ssize_t *vi, inc;
- size_t len;
-
- /* Prepare reference argument. */
- if (SCM_I_ARRAYP (ra0))
- {
- kmax = SCM_I_ARRAY_NDIM (ra0)-1;
- inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
- va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
-
- /* Find unroll depth */
- for (kroll = MAX (0, kmax); kroll > 0; --kroll)
- {
- inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
- if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
- break;
- }
- }
- else
- {
- kroll = kmax = 0;
- va0 = ra0 = make1array (ra0, 1);
- }
-
- /* Prepare rest arguments. */
- lva = SCM_EOL;
- plva = &lva;
- for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
- {
- SCM va1, ra1 = SCM_CAR (z);
- if (SCM_I_ARRAYP (ra1))
- {
- if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
- inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
-
- /* Check unroll depth. */
- for (k = kmax; k > kroll; --k)
- {
- ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
- if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
- inc *= (u0 - l0 + 1);
- if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
- {
- kroll = k;
- break;
- }
- }
-
- /* Check matching of not-unrolled axes. */
- for (; k>=0; --k)
- if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
- }
- else
- {
- if (kmax != 0)
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
- va1 = make1array (ra1, 1);
-
- if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND
(va1, 0))
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1
(ra0));
- }
- *plva = scm_cons (va1, SCM_EOL);
- plva = SCM_CDRLOC (*plva);
- }
-
- /* Check emptiness of not-unrolled axes. */
- for (k = 0; k < kroll; ++k)
- if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
- return 1;
-
- /* Set unrolled size. */
- for (len = 1; k <= kmax; ++k)
- len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
- UBND (va0, 0) = len - 1;
- for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
- UBND (SCM_CAR (z), 0) = len - 1;
-
- /* Set starting indices and go. */
- vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
- for (k = 0; k < kroll; ++k)
- vi[k] = LBND (ra0, k);
- do
- {
- if (k == kroll)
- {
- SCM y = lra;
- SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
- for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
- if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data,
lva)))
- return 0;
- --k;
- }
- else if (vi[k] < UBND (ra0, k))
- {
- ++vi[k];
- ++k;
- }
- else
- {
- vi[k] = LBND (ra0, k) - 1;
- --k;
- }
- }
- while (k >= 0);
-
- return 1;
-}
-
-#undef UBND
-#undef LBND
-
-static int
-rafill (SCM dst, SCM fill)
-{
- size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1;
- size_t i = SCM_I_ARRAY_BASE (dst);
- ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc;
- scm_t_array_handle h;
- dst = SCM_I_ARRAY_V (dst);
- scm_array_get_handle (dst, &h);
-
- for (; n-- > 0; i += inc)
- h.vset (h.vector, i, fill);
-
- scm_array_handle_release (&h);
- return 1;
-}
-
-SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
- (SCM ra, SCM fill),
- "Store @var{fill} in every element of array @var{ra}. The value\n"
- "returned is unspecified.")
-#define FUNC_NAME s_scm_array_fill_x
-{
- scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static int
-racp (SCM src, SCM dst)
-{
- size_t i_s, i_d, n;
- ssize_t inc_s, inc_d;
- scm_t_array_handle h_s, h_d;
- dst = SCM_CAR (dst);
- i_s = SCM_I_ARRAY_BASE (src);
- i_d = SCM_I_ARRAY_BASE (dst);
- n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1);
- inc_s = SCM_I_ARRAY_DIMS (src)->inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
- src = SCM_I_ARRAY_V (src);
- dst = SCM_I_ARRAY_V (dst);
- scm_array_get_handle (src, &h_s);
- scm_array_get_handle (dst, &h_d);
-
- if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
- && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
- {
- SCM const * el_s = h_s.elements;
- SCM * el_d = h_d.writable_elements;
- if (!el_d && n>0)
- scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array");
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- el_d[i_d] = el_s[i_s];
- }
- else
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s));
-
- scm_array_handle_release (&h_d);
- scm_array_handle_release (&h_s);
-
- return 1;
-}
-
-SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0,
scm_array_copy_x);
-
-
-SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
- (SCM src, SCM dst),
- "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
- "Copy every element from vector or array @var{src} to the\n"
- "corresponding element of @var{dst}. @var{dst} must have the\n"
- "same rank as @var{src}, and be at least as large in each\n"
- "dimension. The order is unspecified.")
-#define FUNC_NAME s_scm_array_copy_x
-{
- scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static int
-ramap (SCM ra0, SCM proc, SCM ras)
-{
- size_t i0 = SCM_I_ARRAY_BASE (ra0);
- ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
- scm_t_array_handle h0;
- ra0 = SCM_I_ARRAY_V (ra0);
- scm_array_get_handle (ra0, &h0);
-
- if (scm_is_null (ras))
- for (; n--; i0 += inc0)
- h0.vset (h0.vector, i0, scm_call_0 (proc));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- size_t i1 = SCM_I_ARRAY_BASE (ra1);
- ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
- scm_t_array_handle h1;
- ra1 = SCM_I_ARRAY_V (ra1);
- scm_array_get_handle (ra1, &h1);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- for (; n--; i0 += inc0, i1 += inc1)
- h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
- else
- {
- SCM ra2 = SCM_CAR (ras);
- size_t i2 = SCM_I_ARRAY_BASE (ra2);
- ssize_t inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
- scm_t_array_handle h2;
- ra2 = SCM_I_ARRAY_V (ra2);
- scm_array_get_handle (ra2, &h2);
- ras = SCM_CDR (ras);
- if (scm_is_null (ras))
- for (; n--; i0 += inc0, i1 += inc1, i2 += inc2)
- h0.vset (h0.vector, i0, scm_call_2 (proc, h1.vref (h1.vector,
i1), h2.vref (h2.vector, i2)));
- else
- {
- scm_t_array_handle *hs;
- size_t restn = scm_ilength (ras);
- SCM args = SCM_EOL;
- SCM *p = &args;
- SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
- size_t k;
- ssize_t i;
-
- for (k = 0; k < restn; ++k)
- {
- *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
- sa[k] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
-
- hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn,
vi_gc_hint);
- for (k = 0; k < restn; ++k, ras = scm_cdr (ras))
- scm_array_get_handle (scm_car (ras), hs+k);
-
- for (i = 0; n--; i0 += inc0, i1 += inc1, i2 += inc2, ++i)
- {
- for (k = 0; k < restn; ++k)
- *(sa[k]) = scm_array_handle_ref (hs+k,
i*hs[k].dims[0].inc);
- h0.vset (h0.vector, i0, scm_apply_2 (proc, h1.vref
(h1.vector, i1), h2.vref (h2.vector, i2), args));
- }
-
- for (k = 0; k < restn; ++k)
- scm_array_handle_release (hs+k);
- }
- scm_array_handle_release (&h2);
- }
- scm_array_handle_release (&h1);
- }
- scm_array_handle_release (&h0);
- return 1;
-}
-
-
-SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1,
scm_array_map_x);
-
-SCM_SYMBOL (sym_b, "b");
-
-SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
- (SCM ra0, SCM proc, SCM lra),
- "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
- "@var{array1}, @dots{} must have the same number of dimensions\n"
- "as @var{ra0} and have a range for each index which includes the\n"
- "range for the corresponding index in @var{ra0}. @var{proc} is\n"
- "applied to each tuple of elements of @var{array1}, @dots{} and\n"
- "the result is stored as the corresponding element in @var{ra0}.\n"
- "The value returned is unspecified. The order of application is\n"
- "unspecified.")
-#define FUNC_NAME s_scm_array_map_x
-{
- SCM_VALIDATE_PROC (2, proc);
- SCM_VALIDATE_REST_ARGUMENT (lra);
-
- scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static int
-rafe (SCM ra0, SCM proc, SCM ras)
-{
- size_t i0 = SCM_I_ARRAY_BASE (ra0);
- ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1;
- scm_t_array_handle h0;
- ra0 = SCM_I_ARRAY_V (ra0);
- scm_array_get_handle (ra0, &h0);
-
- if (scm_is_null (ras))
- for (; n--; i0 += inc0)
- scm_call_1 (proc, h0.vref (h0.vector, i0));
- else
- {
- scm_t_array_handle *hs;
- size_t restn = scm_ilength (ras);
-
- SCM args = SCM_EOL;
- SCM *p = &args;
- SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k)
- {
- *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
- sa[k] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
-
- hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint);
- for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras))
- scm_array_get_handle (scm_car (ras), hs+k);
-
- for (ssize_t i = 0; n--; i0 += inc0, ++i)
- {
- for (size_t k = 0; k < restn; ++k)
- *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc);
- scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
- }
-
- for (size_t k = 0; k < restn; ++k)
- scm_array_handle_release (hs+k);
- }
- scm_array_handle_release (&h0);
- return 1;
-}
-
-SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
- (SCM proc, SCM ra0, SCM lra),
- "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
- "in row-major order. The value returned is unspecified.")
-#define FUNC_NAME s_scm_array_for_each
-{
- SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_REST_ARGUMENT (lra);
- scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-static void
-array_index_map_1 (SCM ra, SCM proc)
-{
- scm_t_array_handle h;
- ssize_t i, inc;
- size_t p;
- scm_array_get_handle (ra, &h);
- inc = h.dims[0].inc;
- for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
- h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i)));
- scm_array_handle_release (&h);
-}
-
-/* Here we assume that the array is a scm_tc7_array, as that is the only
- kind of array in Guile that supports rank > 1. */
-static void
-array_index_map_n (SCM ra, SCM proc)
-{
- scm_t_array_handle h;
- int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- SCM args = SCM_EOL;
- SCM *p = &args;
-
- ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1),
vi_gc_hint);
- SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1),
vi_gc_hint);
-
- for (k = 0; k <= kmax; k++)
- {
- vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
- return;
- *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL);
- si[k] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
-
- scm_array_get_handle (ra, &h);
- k = kmax;
- do
- {
- if (k == kmax)
- {
- size_t i;
- vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
- i = cindk (ra, vi, kmax+1);
- for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
- {
- *(si[kmax]) = scm_from_ssize_t (vi[kmax]);
- h.vset (h.vector, i, scm_apply_0 (proc, args));
- i += SCM_I_ARRAY_DIMS (ra)[kmax].inc;
- }
- k--;
- }
- else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
- {
- *(si[k]) = scm_from_ssize_t (++vi[k]);
- k++;
- }
- else
- {
- vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
- k--;
- }
- }
- while (k >= 0);
- scm_array_handle_release (&h);
-}
-
-SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
- (SCM ra, SCM proc),
- "Apply @var{proc} to the indices of each element of @var{ra} in\n"
- "turn, storing the result in the corresponding element. The
value\n"
- "returned and the order of application are unspecified.\n\n"
- "One can implement @var{array-indexes} as\n"
- "@lisp\n"
- "(define (array-indexes array)\n"
- " (let ((ra (apply make-array #f (array-shape array))))\n"
- " (array-index-map! ra (lambda x x))\n"
- " ra))\n"
- "@end lisp\n"
- "Another example:\n"
- "@lisp\n"
- "(define (apl:index-generator n)\n"
- " (let ((v (make-uniform-vector n 1)))\n"
- " (array-index-map! v (lambda (i) i))\n"
- " v))\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_index_map_x
-{
- SCM_VALIDATE_PROC (2, proc);
-
- switch (scm_c_array_rank (ra))
- {
- case 0:
- scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
- break;
- case 1:
- array_index_map_1 (ra, proc);
- break;
- default:
- array_index_map_n (ra, proc);
- break;
- }
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-static int
-array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
- size_t dim, unsigned long posx, unsigned long posy)
-{
- if (dim == scm_array_handle_rank (hx))
- return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
- scm_array_handle_ref (hy, posy)));
- else
- {
- long incx, incy;
- size_t i;
-
- if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
- || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
- return 0;
-
- i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
-
- incx = hx->dims[dim].inc;
- incy = hy->dims[dim].inc;
- posx += (i - 1) * incx;
- posy += (i - 1) * incy;
-
- for (; i > 0; i--, posx -= incx, posy -= incy)
- if (!array_compare (hx, hy, dim + 1, posx, posy))
- return 0;
- return 1;
- }
-}
-
-SCM
-scm_array_equal_p (SCM x, SCM y)
-{
- scm_t_array_handle hx, hy;
- SCM res;
-
- scm_array_get_handle (x, &hx);
- scm_array_get_handle (y, &hy);
-
- scm_t_array_element_type t1 = hx.element_type;
- scm_t_array_element_type t2 = hy.element_type;
-
- /* R6RS and Guile mostly use #vu8(...) as the literal syntax for
- bytevectors, but R7RS uses #u8. To allow R7RS users to re-use the
- various routines implemented on bytevectors which return vu8-tagged
- values and to also be able to do (equal? #u8(1 2 3) (bytevector 1 2
- 3)), we allow equality comparisons between vu8 and u8. */
- if (t1 == SCM_ARRAY_ELEMENT_TYPE_VU8)
- t1 = SCM_ARRAY_ELEMENT_TYPE_U8;
- if (t2 == SCM_ARRAY_ELEMENT_TYPE_VU8)
- t2 = SCM_ARRAY_ELEMENT_TYPE_U8;
-
- res = scm_from_bool (hx.ndims == hy.ndims && t1 == t2);
-
- if (scm_is_true (res))
- res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
-
- scm_array_handle_release (&hy);
- scm_array_handle_release (&hx);
-
- return res;
-}
-
-static SCM scm_i_array_equal_p (SCM, SCM, SCM);
-SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
- (SCM ra0, SCM ra1, SCM rest),
- "Return @code{#t} iff all arguments are arrays with the same\n"
- "shape, the same type, and have corresponding elements which are\n"
- "either @code{equal?} or @code{array-equal?}. This function\n"
- "differs from @code{equal?} in that all arguments must be arrays.")
-#define FUNC_NAME s_scm_i_array_equal_p
-{
- if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
- return SCM_BOOL_T;
-
- while (!scm_is_null (rest))
- {
- if (scm_is_false (scm_array_equal_p (ra0, ra1)))
- return SCM_BOOL_F;
- ra0 = ra1;
- ra1 = scm_car (rest);
- rest = scm_cdr (rest);
- }
- return scm_array_equal_p (ra0, ra1);
-}
-#undef FUNC_NAME
-
-
-/* Copy array descriptor with different base. */
-SCM
-scm_i_array_rebase (SCM a, size_t base)
-{
- size_t ndim = SCM_I_ARRAY_NDIM (a);
- SCM b = scm_i_raw_array (ndim);
- SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a));
-/* FIXME do check base */
- SCM_I_ARRAY_SET_BASE (b, base);
- memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof
(scm_t_array_dim)*ndim);
- return b;
-}
-
-static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) &
~(sizeof (void *) - 1); }
-
-SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
- (SCM frame_rank, SCM op, SCM args),
- "Apply @var{op} to each of the cells of rank
rank(@var{arg})-@var{frame_rank}\n"
- "of the arrays @var{args}, in unspecified order. The first\n"
- "@var{frame_rank} dimensions of each @var{arg} must match.\n"
- "Rank-0 cells are passed as rank-0 arrays.\n\n"
- "The value returned is unspecified.\n\n"
- "For example:\n"
- "@lisp\n"
- ";; Sort the rows of rank-2 array A.\n\n"
- "(array-slice-for-each 1 (lambda (x) (sort! x <)) a)\n"
- "\n"
- ";; Compute the arguments of the (x y) vectors in the rows of
rank-2\n"
- ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
- ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1)
array.\n\n"
- "(array-slice-for-each 1 \n"
- " (lambda (xy angle)\n"
- " (array-set! angle (atan (array-ref xy 1) (array-ref xy
0))))\n"
- " xys angles)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_slice_for_each
-{
- SCM xargs = args;
- int const N = scm_ilength (args);
- int const frank = scm_to_int (frame_rank);
- int ocd;
- ssize_t step;
- SCM dargs_ = SCM_EOL;
- char const * msg;
- scm_t_array_dim * ais;
- int n, k;
- ssize_t z;
-
- /* to be allocated inside the pool */
- scm_t_array_handle * ah;
- SCM * args_;
- scm_t_array_dim ** as;
- int * rank;
-
- ssize_t * s;
- SCM * ai;
- SCM ** dargs;
- ssize_t * i;
-
- int * order;
- size_t * base;
-
- /* size the pool */
- char * pool;
- char * pool0;
- size_t pool_size = 0;
- pool_size += padtoptr(N*sizeof (scm_t_array_handle));
- pool_size += padtoptr(N*sizeof (SCM));
- pool_size += padtoptr(N*sizeof (scm_t_array_dim *));
- pool_size += padtoptr(N*sizeof (int));
-
- pool_size += padtoptr(frank*sizeof (ssize_t));
- pool_size += padtoptr(N*sizeof (SCM));
- pool_size += padtoptr(N*sizeof (SCM *));
- pool_size += padtoptr(frank*sizeof (ssize_t));
-
- pool_size += padtoptr(frank*sizeof (int));
- pool_size += padtoptr(N*sizeof (size_t));
- pool = scm_gc_malloc (pool_size, "pool");
-
- /* place the items in the pool */
-#define AFIC_ALLOC_ADVANCE(pool, count, type, name) \
- name = (void *)pool; \
- pool += padtoptr(count*sizeof (type));
-
- pool0 = pool;
- AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah);
- AFIC_ALLOC_ADVANCE (pool, N, SCM, args_);
- AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as);
- AFIC_ALLOC_ADVANCE (pool, N, int, rank);
-
- AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s);
- AFIC_ALLOC_ADVANCE (pool, N, SCM, ai);
- AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs);
- AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i);
-
- AFIC_ALLOC_ADVANCE (pool, frank, int, order);
- AFIC_ALLOC_ADVANCE (pool, N, size_t, base);
- assert((pool0+pool_size==pool) && "internal error");
-#undef AFIC_ALLOC_ADVANCE
-
- for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
- {
- args_[n] = scm_car(xargs);
- scm_array_get_handle(args_[n], ah+n);
- as[n] = scm_array_handle_dims(ah+n);
- rank[n] = scm_array_handle_rank(ah+n);
- }
- /* checks */
- msg = NULL;
- if (frank<0)
- msg = "bad frame rank ~S, ~S";
- else
- {
- for (n=0; n!=N; ++n)
- {
- if (rank[n]<frank)
- {
- msg = "frame too large for arguments: ~S, ~S";
- goto check_msg;
- }
- for (k=0; k!=frank; ++k)
- {
- if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
- {
- msg = "mismatched frames: ~S, ~S";
- goto check_msg;
- }
- s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
-
- /* this check is needed if the array cannot be entirely */
- /* unrolled, because the unrolled subloop will be run before */
- /* checking the dimensions of the frame. */
- if (s[k]==0)
- goto end;
- }
- }
- }
- check_msg: ;
- if (msg!=NULL)
- {
- for (n=0; n!=N; ++n)
- scm_array_handle_release(ah+n);
- scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
- }
- /* prepare moving cells. */
- for (n=0; n!=N; ++n)
- {
- ai[n] = scm_i_make_array(rank[n]-frank);
- SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
- /* FIXME scm_array_handle_base (ah+n) should be in Guile */
- SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
- ais = SCM_I_ARRAY_DIMS(ai[n]);
- for (k=frank; k!=rank[n]; ++k)
- {
- ais[k-frank] = as[n][k];
- }
- }
- /* prepare rest list for callee. */
- {
- SCM *p = &dargs_;
- for (n=0; n<N; ++n)
- {
- *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL);
- dargs[n] = SCM_CARLOC (*p);
- p = SCM_CDRLOC (*p);
- }
- }
- /* special case for rank 0. */
- if (frank==0)
- {
- for (n=0; n<N; ++n)
- *dargs[n] = ai[n];
- scm_apply_0(op, dargs_);
- for (n=0; n<N; ++n)
- scm_array_handle_release(ah+n);
- return SCM_UNSPECIFIED;
- }
- /* FIXME determine best looping order. */
- for (k=0; k!=frank; ++k)
- {
- i[k] = 0;
- order[k] = frank-1-k;
- }
- /* find outermost compact dim. */
- step = s[order[0]];
- ocd = 1;
- for (; ocd<frank; step *= s[order[ocd]], ++ocd)
- for (n=0; n!=N; ++n)
- if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc)
- goto ocd_reached;
- ocd_reached: ;
- /* rank loop. */
- for (n=0; n!=N; ++n)
- base[n] = SCM_I_ARRAY_BASE(ai[n]);
- for (;;)
- {
- /* unrolled loop. */
- for (z=0; z!=step; ++z)
- {
- /* we are forced to create fresh array descriptors for each */
- /* call since we don't know whether the callee will keep them, */
- /* and Guile offers no way to copy the descriptor (since */
- /* descriptors are immutable). Yet another reason why this */
- /* should be in Scheme. */
- for (n=0; n<N; ++n)
- {
- *dargs[n] = scm_i_array_rebase(ai[n], base[n]);
- base[n] += as[n][order[0]].inc;
- }
- scm_apply_0(op, dargs_);
- }
- for (n=0; n<N; ++n)
- base[n] -= step*as[n][order[0]].inc;
- for (k=ocd; ; ++k)
- {
- if (k==frank)
- goto end;
- else if (i[order[k]]<s[order[k]]-1)
- {
- ++i[order[k]];
- for (n=0; n<N; ++n)
- base[n] += as[n][order[k]].inc;
- break;
- }
- else
- {
- i[order[k]] = 0;
- for (n=0; n<N; ++n)
- base[n] += as[n][order[k]].inc*(1-s[order[k]]);
- }
- }
- }
- end:;
- for (n=0; n<N; ++n)
- scm_array_handle_release(ah+n);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_array_slice_for_each_in_order,
"array-slice-for-each-in-order", 2, 0, 1,
- (SCM frank, SCM op, SCM a),
- "Same as array-slice-for-each, but visit the cells sequentially\n"
- "and in row-major order.\n")
-#define FUNC_NAME s_scm_array_slice_for_each_in_order
-{
- return scm_array_slice_for_each (frank, op, a);
-}
-#undef FUNC_NAME
-
-
-void
-scm_init_array_map (void)
-{
-#include "array-map.x"
- scm_add_feature (s_scm_array_for_each);
-}
diff --git a/libguile/array-map.h b/libguile/array-map.h
deleted file mode 100644
index 3e96bec1f..000000000
--- a/libguile/array-map.h
+++ /dev/null
@@ -1,44 +0,0 @@
-#ifndef SCM_ARRAY_MAP_H
-#define SCM_ARRAY_MAP_H
-
-/* Copyright 1995-1997,2000,2006,2008-2011,2013,2015,2018
- 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/scm.h"
-
-
-
-SCM_API int scm_ra_matchp (SCM ra0, SCM ras);
-SCM_API int scm_ramapc (void *cproc, SCM data, SCM ra0, SCM lra,
- const char *what);
-SCM_API SCM scm_array_fill_x (SCM ra, SCM fill);
-SCM_API SCM scm_array_copy_x (SCM src, SCM dst);
-SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
-SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
-SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
-SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
-SCM_API SCM scm_array_slice_for_each (SCM frank, SCM op, SCM args);
-SCM_API SCM scm_array_slice_for_each_in_order (SCM frank, SCM op, SCM args);
-
-SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base);
-SCM_INTERNAL void scm_init_array_map (void);
-
-#endif /* SCM_ARRAY_MAP_H */
diff --git a/libguile/arrays.c b/libguile/arrays.c
index cf9ec8c62..46ac7bfc8 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,7 +28,6 @@
#include <errno.h>
#include <string.h>
-#include "array-map.h"
#include "bitvectors.h"
#include "boolean.h"
#include "chars.h"
@@ -49,7 +48,9 @@
#include "srfi-13.h"
#include "srfi-4.h"
#include "strings.h"
+#include "threads.h"
#include "uniform.h"
+#include "variable.h"
#include "vectors.h"
#include "arrays.h"
@@ -785,109 +786,6 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
#undef FUNC_NAME
-SCM_DEFINE (scm_array_cell_ref, "array-cell-ref", 1, 0, 1,
- (SCM ra, SCM indices),
- "Return the element at the @code{(@var{indices} ...)} position\n"
- "in array @var{ra}, or the array slice @var{ra}[@var{indices} ...,
...]\n"
- "if the rank of @var{ra} is larger than the number of indices.\n\n"
- "See also @code{array-ref}, @code{array-slice},
@code{array-cell-set!}.\n\n"
- "@code{array-cell-ref} never returns a rank 0 array. For
example:\n"
- "@lisp\n"
- "(array-cell-ref #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n"
- "(array-cell-ref #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n"
- "(array-cell-ref #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5
6))\n"
- "(array-cell-ref #0(5) @result{} 5.\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_cell_ref
-{
- scm_t_array_handle handle;
- scm_array_get_handle (ra, &handle);
- SCM i = indices;
- size_t k;
- ssize_t pos = 0;
- scm_t_array_dim *s;
- array_from_pos (&handle, &k, &i, &pos, &s);
- 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 o;
- if (k>0)
- array_from_get_o (&handle, k, s, pos, &o);
- else if (scm_is_null(i))
- o = scm_array_handle_ref (&handle, pos);
- else
- {
- scm_array_handle_release (&handle);
- scm_misc_error (FUNC_NAME, "too many indices ~a for rank ~a", scm_list_2
(indices, scm_array_rank (ra)));
- }
- scm_array_handle_release (&handle);
- return o;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_array_cell_set_x, "array-cell-set!", 2, 0, 1,
- (SCM ra, SCM b, SCM indices),
- "Set the array slice @var{ra}[@var{indices} ..., ...] to
@var{b}\n."
- "Equivalent to @code{(array-copy! @var{b} (apply array-cell-ref
@var{ra} @var{indices}))}\n"
- "if the number of indices is smaller than the rank of @var{ra};
otherwise\n"
- "equivalent to @code{(apply array-set! @var{ra} @var{b}
@var{indices})}.\n"
- "This function returns the modified array @var{ra}.\n\n"
- "See also @code{array-ref}, @code{array-cell-ref},
@code{array-slice}.\n\n"
- "For example:\n"
- "@lisp\n"
- "(define A (list->array 2 '((1 2 3) (4 5 6))))\n"
- "(array-cell-set! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99)
6))\n"
- "(array-cell-set! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n"
- "(array-cell-set! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n"
- "(array-cell-set! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8
7))\n\n"
- "(define B (make-array 0))\n"
- "(array-cell-set! B 15) @result{} #0(15)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_cell_set_x
-{
- scm_t_array_handle handle;
- scm_array_get_handle (ra, &handle);
- SCM i = indices;
- size_t k;
- ssize_t pos = 0;
- scm_t_array_dim *s;
- array_from_pos (&handle, &k, &i, &pos, &s);
- 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)));
- }
- if (k>0)
- {
- SCM o;
- array_from_get_o(&handle, k, s, pos, &o);
- scm_array_handle_release(&handle);
- /* an error is still possible here if o and b don't match. */
- /* FIXME copying like this wastes the handle, and the bounds matching
- behavior of array-copy! is not strict. */
- scm_array_copy_x(b, o);
- }
- else if (scm_is_null(i))
- {
- scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */
- scm_array_handle_release (&handle);
- }
- else
- {
- scm_array_handle_release (&handle);
- scm_misc_error (FUNC_NAME, "too many indices ~a for rank ~a", scm_list_2
(indices, scm_array_rank (ra)));
- }
- return ra;
-}
-#undef FUNC_NAME
-
-
-#undef ARRAY_FROM_GET_O
-
-
/* args are RA . DIMS */
SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
@@ -1235,6 +1133,37 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
return d;
}
+static SCM array_equal_p_var;
+static SCM array_copy_var;
+
+static void
+init_array_map_vars (void)
+{
+ array_equal_p_var = scm_c_public_lookup ("ice-9 arrays", "array-equal?");
+ array_copy_var = scm_c_public_lookup ("ice-9 arrays", "array-copy");
+}
+
+static void
+init_array_map_functions (void)
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_array_map_vars);
+}
+
+SCM
+scm_i_array_equal_p (SCM ra0, SCM ra1)
+{
+ init_array_map_functions ();
+ return scm_call_2 (scm_variable_ref (array_equal_p_var), ra0, ra1);
+}
+
+SCM
+scm_i_array_copy (SCM ra)
+{
+ init_array_map_functions ();
+ return scm_call_1 (scm_variable_ref (array_copy_var), ra);
+}
+
void
scm_init_arrays ()
{
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5457ddb95..40e3ad7bd 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -1,7 +1,7 @@
#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H
-/* Copyright 1995-1997,1999-2001,2004,2006,2008-2010,2012,2018
+/* Copyright 1995-1997,1999-2001,2004,2006,2008-2010,2012,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -50,8 +50,6 @@ SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc,
SCM dims);
SCM_API SCM scm_transpose_array (SCM ra, SCM args);
SCM_API SCM scm_array_contents (SCM ra, SCM strict);
SCM_API SCM scm_array_slice (SCM ra, SCM indices);
-SCM_API SCM scm_array_cell_ref (SCM ra, SCM indices);
-SCM_API SCM scm_array_cell_set_x (SCM ra, SCM b, SCM indices);
SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
@@ -84,6 +82,10 @@ SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v);
+SCM_INTERNAL SCM scm_i_array_equal_p (SCM ra0, SCM ra1);
+SCM_INTERNAL SCM scm_i_array_copy (SCM ra);
+
+
typedef struct scm_t_array_dim
{
ssize_t lbnd;
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 8078b680d..7da74fb8a 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -304,6 +304,116 @@ scm_cons_source (SCM orig, SCM x, SCM y)
return scm_call_3 (scm_variable_ref (cons_source_var), orig, x, y);
}
+/* In versions 3.0 and prior, the hash table interface could also access
+ weak tables. This is now deprecated. */
+
+
+
+static SCM array_fill_x_var;
+static SCM array_copy_x_var;
+static SCM array_map_x_var;
+static SCM array_for_each_var;
+static SCM array_index_map_x_var;
+static SCM array_equal_p_var;
+static SCM array_slice_for_each_var;
+static SCM array_cell_ref_var;
+static SCM array_cell_set_x_var;
+
+static void
+init_array_map_vars (void)
+{
+ array_fill_x_var = scm_c_public_lookup ("ice-9 arrays", "array-fill!");
+ array_copy_x_var = scm_c_public_lookup ("ice-9 arrays", "array-copy!");
+ array_map_x_var = scm_c_public_lookup ("ice-9 arrays", "array-map!");
+ array_for_each_var = scm_c_public_lookup ("ice-9 arrays", "array-for-each");
+ array_index_map_x_var = scm_c_public_lookup ("ice-9 arrays",
"array-index-map!");
+ array_equal_p_var = scm_c_public_lookup ("ice-9 arrays", "array-equal?");
+ array_fill_x_var = scm_c_public_lookup ("ice-9 arrays", "array-fill!");
+ array_cell_ref_var = scm_c_public_lookup ("ice-9 arrays", "array-cell-ref");
+ array_cell_set_x_var = scm_c_public_lookup ("ice-9 arrays",
"array-cell-set!");
+}
+
+static void
+init_array_map_functions (void)
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_c_issue_deprecation_warning
+ ("Using the array map functions from C is deprecated. Invoke "
+ "array-map!, etc. from (ice-9 arrays) instead.");
+ scm_i_pthread_once (&once, init_array_map_vars);
+}
+
+SCM
+scm_array_fill_x (SCM ra, SCM fill)
+{
+ init_array_map_functions ();
+ return scm_call_2 (scm_variable_ref (array_fill_x_var), ra, fill);
+}
+
+SCM
+scm_array_copy_x (SCM src, SCM dst)
+{
+ init_array_map_functions ();
+ return scm_call_2 (scm_variable_ref (array_copy_x_var), src, dst);
+}
+
+SCM
+scm_array_map_x (SCM ra0, SCM proc, SCM lra)
+{
+ init_array_map_functions ();
+ return scm_apply_2 (scm_variable_ref (array_map_x_var), ra0, proc, lra);
+}
+
+SCM
+scm_array_for_each (SCM proc, SCM ra0, SCM lra)
+{
+ init_array_map_functions ();
+ return scm_apply_2 (scm_variable_ref (array_for_each_var), proc, ra0, lra);
+}
+
+SCM
+scm_array_index_map_x (SCM ra, SCM proc)
+{
+ init_array_map_functions ();
+ return scm_call_2 (scm_variable_ref (array_index_map_x_var), ra, proc);
+}
+
+SCM
+scm_array_equal_p (SCM ra0, SCM ra1)
+{
+ init_array_map_functions ();
+ return scm_call_2 (scm_variable_ref (array_equal_p_var), ra0, ra1);
+}
+
+SCM
+scm_array_slice_for_each (SCM frank, SCM op, SCM args)
+{
+ init_array_map_functions ();
+ return scm_apply_2 (scm_variable_ref (array_slice_for_each_var), frank, op,
+ args);
+}
+
+SCM
+scm_array_slice_for_each_in_order (SCM frank, SCM op, SCM args)
+{
+ return scm_array_slice_for_each (frank, op, args);
+}
+
+SCM
+scm_array_cell_ref (SCM array, SCM indices)
+{
+ init_array_map_functions ();
+ return scm_apply_1 (scm_variable_ref (array_cell_ref_var), array, indices);
+}
+
+SCM
+scm_array_cell_set_x (SCM array, SCM val, SCM indices)
+{
+ init_array_map_functions ();
+ return scm_apply_2 (scm_variable_ref (array_cell_set_x_var), array, val,
+ indices);
+}
+
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index f0189a676..bade32244 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -64,6 +64,17 @@ SCM_DEPRECATED SCM scm_source_properties (SCM obj);
SCM_DEPRECATED SCM scm_set_source_properties_x (SCM obj, SCM props);
SCM_DEPRECATED SCM scm_cons_source (SCM xorig, SCM x, SCM y);
+SCM_DEPRECATED SCM scm_array_fill_x (SCM ra, SCM fill);
+SCM_DEPRECATED SCM scm_array_copy_x (SCM src, SCM dst);
+SCM_DEPRECATED SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
+SCM_DEPRECATED SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
+SCM_DEPRECATED SCM scm_array_index_map_x (SCM ra, SCM proc);
+SCM_DEPRECATED SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_DEPRECATED SCM scm_array_slice_for_each (SCM frank, SCM op, SCM args);
+SCM_DEPRECATED SCM scm_array_slice_for_each_in_order (SCM frank, SCM op, SCM
args);
+SCM_DEPRECATED SCM scm_array_cell_ref (SCM array, SCM indices);
+SCM_DEPRECATED SCM scm_array_cell_set_x (SCM array, SCM val, SCM indices);
+
/* Deprecated declarations go here. */
void scm_i_init_deprecated (void);
diff --git a/libguile/eq.c b/libguile/eq.c
index d4d51a05e..57e4b931a 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -25,7 +25,7 @@
#include <math.h>
#include <string.h>
-#include "array-map.h"
+#include "arrays.h"
#include "async.h"
#include "bitvectors.h"
#include "boolean.h"
@@ -329,7 +329,7 @@ scm_equal_p (SCM x, SCM y)
/* Vectors can be equal to one-dimensional arrays.
*/
if (scm_is_array (x) && scm_is_array (y))
- return scm_array_equal_p (x, y);
+ return scm_i_array_equal_p (x, y);
return SCM_BOOL_F;
}
@@ -367,7 +367,7 @@ scm_equal_p (SCM x, SCM y)
case scm_tc7_bytevector:
return scm_bytevector_eq_p (x, y);
case scm_tc7_array:
- return scm_array_equal_p (x, y);
+ return scm_i_array_equal_p (x, y);
case scm_tc7_bitvector:
return scm_i_bitvector_equal_p (x, y);
case scm_tc7_vector:
diff --git a/libguile/init.c b/libguile/init.c
index a5935a437..c52de0c53 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -41,7 +41,6 @@
/* Everybody has an init function. */
#include "alist.h"
-#include "array-map.h"
#include "arrays.h"
#include "async.h"
#include "atomic.h"
@@ -435,7 +434,6 @@ scm_i_init_guile (struct gc_stack_addr base)
scm_init_bitvectors (); /* Requires smob_prehistory, array-handle */
scm_bootstrap_srfi_4 (); /* Requires smob_prehistory, array-handle */
scm_init_arrays (); /* Requires smob_prehistory, array-handle */
- scm_init_array_map ();
scm_init_frames (); /* Requires smob_prehistory */
scm_init_stacks (); /* Requires strings, struct, frames */
diff --git a/libguile/sort.c b/libguile/sort.c
index 38f64c37c..63e3dff41 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,4 @@
-/* Copyright 1999-2002,2004,2006-2012,2014,2018
+/* Copyright 1999-2002,2004,2006-2012,2014,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -39,7 +39,6 @@
# include <config.h>
#endif
-#include "array-map.h"
#include "arrays.h"
#include "async.h"
#include "boolean.h"
@@ -467,12 +466,9 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
{
- SCM copy;
if (scm_c_array_rank (items) != 1)
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items,
SCM_EOL);
- copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED,
scm_array_dimensions (items));
- scm_array_copy_x (items, copy);
- return scm_sort_x (copy, less);
+ return scm_sort_x (scm_i_array_copy (items), less);
}
else
SCM_WRONG_TYPE_ARG (1, items);
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index f03eb351b..ac1f656d3 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 1999, 2001, 2004, 2006, 2017 Free Software Foundation, Inc.
+;;; Copyright (C) 1999, 2001, 2004, 2006, 2017, 2025 Free Software Foundation,
Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -18,22 +18,636 @@
(define-module (ice-9 arrays)
#:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
- #:export (array-copy))
+ #:export (array-copy)
+ ;; FIXME: Use #:export when deprecated code removed.
+ #:replace (array-fill!
+ array-copy!
+ array-copy-in-order!
+ array-map!
+ array-for-each
+ array-index-map!
+ array-equal?
+ array-slice-for-each
+ array-slice-for-each-in-order
+ array-cell-ref
+ array-cell-set!))
+
+(define (string-accessors buffer)
+ (values (string-length buffer)
+ (lambda (x i) (string-ref x i))
+ (lambda (x i v) (string-set! x i v))))
+
+(define (vector-accessors buffer)
+ (values (vector-length buffer)
+ (lambda (x i) (vector-ref x i))
+ (lambda (x i v) (vector-set! x i v))))
+
+(define (bitvector-accessors buffer)
+ (values (bitvector-length buffer)
+ (lambda (x i) (bitvector-bit-set? x i))
+ (lambda (x i v)
+ (if v
+ (bitvector-set-bit! x i)
+ (bitvector-clear-bit! x i)))))
+
+(define (bytevector-accessors buffer)
+ (case (array-type buffer)
+ ((u8 vu8)
+ (values (bytevector-length buffer)
+ (lambda (x i) (bytevector-u8-ref x i))
+ (lambda (x i v) (bytevector-u8-set! x i v))))
+ ((s8)
+ (values (bytevector-length buffer)
+ (lambda (x i) (bytevector-s8-ref x i))
+ (lambda (x i v) (bytevector-s8-set! x i v))))
+ ((u16)
+ (values (ash (bytevector-length buffer) -1)
+ (lambda (x i) (bytevector-u16-native-ref x (ash i 1)))
+ (lambda (x i v) (bytevector-u16-native-set! x (ash i 1) v))))
+ ((s16)
+ (values (ash (bytevector-length buffer) -1)
+ (lambda (x i) (bytevector-s16-native-ref x (ash i 2)))
+ (lambda (x i v) (bytevector-s16-native-set! x (ash i 2) v))))
+ ((u32)
+ (values (ash (bytevector-length buffer) -2)
+ (lambda (x i) (bytevector-u32-native-ref x (ash i 2)))
+ (lambda (x i v) (bytevector-u32-native-set! x (ash i 2) v))))
+ ((s32)
+ (values (ash (bytevector-length buffer) -2)
+ (lambda (x i) (bytevector-s32-native-ref x (ash i 2)))
+ (lambda (x i v) (bytevector-s32-native-set! x (ash i 2) v))))
+ ((u64)
+ (values (ash (bytevector-length buffer) -3)
+ (lambda (x i) (bytevector-u64-native-ref x (ash i 3)))
+ (lambda (x i v) (bytevector-u64-native-set! x (ash i 3) v))))
+ ((s64)
+ (values (ash (bytevector-length buffer) -3)
+ (lambda (x i) (bytevector-s64-native-ref x (ash i 3)))
+ (lambda (x i v) (bytevector-s64-native-set! x (ash i 3) v))))
+ ((f32)
+ (values (ash (bytevector-length buffer) -2)
+ (lambda (x i) (bytevector-ieee-single-native-ref x (ash i 2)))
+ (lambda (x i v) (bytevector-ieee-single-native-set! x (ash i 2)
v))))
+ ((f64)
+ (values (ash (bytevector-length buffer) -3)
+ (lambda (x i) (bytevector-ieee-double-native-ref x (ash i 3)))
+ (lambda (x i v) (bytevector-ieee-double-native-set! x (ash i 3)
v))))
+ ((c32)
+ (values (ash (bytevector-length buffer) -3)
+ (lambda (x i)
+ (make-rectangular
+ (bytevector-ieee-single-native-ref x (ash i 3))
+ (bytevector-ieee-single-native-ref x (+ (ash i 3) 4))))
+ (lambda (x i v)
+ (bytevector-ieee-single-native-set! x (ash i 3) (real-part v))
+ (bytevector-ieee-single-native-set! x (+ (ash i 3) 4)
(imag-part v)))))
+ ((c64)
+ (values (ash (bytevector-length buffer) -4)
+ (lambda (x i)
+ (make-rectangular
+ (bytevector-ieee-single-native-ref x (ash i 4))
+ (bytevector-ieee-single-native-ref x (+ (ash i 4) 8))))
+ (lambda (x i v)
+ (bytevector-ieee-single-native-set! x (ash i 4) (real-part v))
+ (bytevector-ieee-single-native-set! x (+ (ash i 3) 8)
(imag-part v)))))
+ (else (error "unreachable"))))
+
+(define (compute-accessors buffer)
+ (cond
+ ((string? buffer) (string-accessors buffer))
+ ((vector? buffer) (vector-accessors buffer))
+ ((bitvector? buffer) (bitvector-accessors buffer))
+ ((bytevector? buffer) (bytevector-accessors buffer))
+ (else
+ (error "bad array buffer"))))
+
+(define (array-shapev a)
+ (let ((v (make-vector (array-rank a))))
+ (let lp ((i 0)
+ (dims (array-dimensions a))
+ (incs (shared-array-increments a)))
+ (match dims
+ (() v)
+ (((start end) . dims)
+ (match incs
+ ((inc . incs)
+ (vector-set! v i (vector start (1+ (- end start)) inc))
+ (lp (1+ i) dims incs))))
+ ((end . dims)
+ (match incs
+ ((inc . incs)
+ (vector-set! v i (vector 0 end inc))
+ (lp (1+ i) dims incs))))))))
+
+(define (shapev<=? a b)
+ (and (eqv? (vector-length a) (vector-length b))
+ (let lp ((i 0))
+ (or (eqv? i (vector-length a))
+ (match (vector-ref a i)
+ (#(abase acount ainc)
+ (match (vector-ref b i)
+ (#(bbase bcount binc)
+ (and (<= bbase abase)
+ (<= (+ abase acount) (+ bbase bcount))
+ (lp (1+ i)))))))))))
+
+(define (prepare-reads dst-shape src)
+ (define src-shape (array-shapev src))
+
+ (unless (shapev<=? dst-shape src-shape)
+ (error "array shape mismatch" dst-shape src))
+
+ (define initial-offset
+ (let lp ((dim 0) (offset (shared-array-offset src)))
+ (cond
+ ((= dim (vector-length dst-shape))
+ offset)
+ (else
+ (match (vector-ref dst-shape dim)
+ (#(dst-start _ _)
+ (match (vector-ref src-shape dim)
+ (#(src-start _ src-inc)
+ (lp (+ dim 1)
+ (+ offset (* (- src-start dst-start) src-inc)))))))))))
+
+ (define incs
+ (let ((incs (make-vector (vector-length src-shape))))
+ (let lp ((dim 0))
+ (when (< dim (vector-length dst-shape))
+ (match (vector-ref src-shape dim)
+ (#(start _ inc)
+ (vector-set! incs dim inc)
+ (lp (+ dim 1))))))
+ incs))
+
+ (define offset initial-offset) ; Mutable.
+
+ (define read
+ (let ((buf (shared-array-root src)))
+ (call-with-values (lambda () (compute-accessors buf))
+ (lambda (length ref set)
+ (lambda () (ref buf offset))))))
+
+ (define (advance! dim)
+ (set! offset (+ offset (vector-ref incs dim))))
+
+ (define (restore! dim count)
+ (set! offset (- offset (* count (vector-ref incs dim)))))
+
+ (values read advance! restore!))
+
+(define (array-map! dst proc . src*)
+ (define dst-buf (shared-array-root dst))
+ (define dst-set (call-with-values (lambda () (compute-accessors dst-buf))
+ (lambda (length ref set) set)))
+ (define dst-dims (array-shapev dst))
+
+ (define src-count (length src*))
+ (define src-advancev (make-vector src-count))
+ (define src-restorev (make-vector src-count))
+ (define src-readv (make-vector src-count))
+
+ (let lp ((i 0) (src* src*))
+ (match src*
+ (() #t)
+ ((src . src*)
+ (call-with-values (lambda () (prepare-reads dst-dims src))
+ (lambda (read advance restore)
+ (vector-set! src-readv i read)
+ (vector-set! src-advancev i advance)
+ (vector-set! src-restorev i restore)))
+ (lp (1+ i) src*))))
+
+ (define proc*
+ (match (vector-length src-readv)
+ (0 proc)
+ (1 (let ((read0 (vector-ref src-readv 0)))
+ (lambda () (proc (read0)))))
+ (2 (let ((read0 (vector-ref src-readv 0))
+ (read1 (vector-ref src-readv 1)))
+ (lambda () (proc (read0) (read1)))))
+ (n (let ((read0 (vector-ref src-readv 0))
+ (read1 (vector-ref src-readv 1))
+ (args (make-list (- n 2))))
+ (lambda ()
+ (let* ((v0 (read0))
+ (v1 (read1)))
+ (let lp ((i 2) (args args))
+ (let ((read (vector-ref src-readv i)))
+ (set-car! args (read))
+ (let ((i (1+ i)))
+ (when (< i n)
+ (lp i (cdr args))))))
+ (apply proc v0 v1 args)))))))
+
+ (define (advance-src-offsets! dim)
+ (let lp ((i 0))
+ (when (< i (vector-length src-advancev))
+ (let ((advance! (vector-ref src-advancev i)))
+ (advance! dim)
+ (lp (1+ i))))))
+
+ (define (restore-src-offsets! dim count)
+ (let lp ((i 0))
+ (when (< i (vector-length src-restorev))
+ (let ((restore! (vector-ref src-restorev i)))
+ (restore! dim count)
+ (lp (1+ i))))))
+
+ (cond
+ ((zero? (vector-length dst-dims))
+ (dst-set dst-buf (shared-array-offset dst) (proc*)))
+ (else
+ (let recur ((dim 0)
+ (dst-offset (shared-array-offset dst)))
+ (match (vector-ref dst-dims dim)
+ (#(start count dst-inc)
+ (if (eq? (1+ dim) (vector-length dst-dims))
+ (let lp ((n 0) (dst-offset dst-offset))
+ (cond
+ ((= n count)
+ (restore-src-offsets! dim count))
+ (else
+ (dst-set dst-buf dst-offset (proc*))
+ (advance-src-offsets! dim)
+ (lp (1+ n) (+ dst-offset dst-inc)))))
+ (let lp ((n 0) (dst-offset dst-offset))
+ (cond
+ ((= n count)
+ (restore-src-offsets! dim count))
+ (else
+ (recur (1+ dim) dst-offset)
+ (advance-src-offsets! dim)
+ (lp (1+ n) (+ dst-offset dst-inc))))))))))))
+
+(define (array-fill! array fill)
+ "Store @var{fill} in every element of array @var{array}. The value
+returned is unspecified."
+ (array-map! array (lambda () fill)))
;; This is actually defined in boot-9.scm, apparently for backwards
;; compatibility.
-
+;;
;; (define (array-shape a)
;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
;; (array-dimensions a)))
+(define (array-copy! src dst)
+ "Copy every element from vector or array @var{src} to the
+corresponding element of @var{dst}. @var{dst} must have the same rank
+as @var{src}, and be at least as large in each dimension. The order is
+unspecified."
+ ;; Unlike array-map! which can read from larger arrays into a smaller,
+ ;; here we can read from a smaller array into a larger. If src is
+ ;; smaller than dst, we need to slice dst.
+ (let ((src-shape (array-shapev src))
+ (dst-shape (array-shapev dst)))
+ (unless (= (vector-length src-shape) (vector-length dst-shape))
+ (error "array shape mismatch" dst-shape src))
+ (array-map! (if (equal? src-shape dst-shape)
+ dst
+ (if (shapev<=? src-shape dst-shape)
+ (apply make-shared-array dst list (array-shape src))
+ (error "array shape mismatch" dst-shape src)))
+ (lambda (v) v)
+ src)))
+
+(define (array-copy-in-order! src dst)
+ "Like @code{array-copy!}, but guaranteed to proceed in row-major order."
+ (array-copy! src dst))
+
; FIXME writes over the array twice if (array-type) is #t
(define (array-copy a)
(let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape
a))))
(array-copy! a b)
b))
+(define (dim-start dim)
+ (match dim ((start end) start) (end 0)))
+(define (dim-end dim)
+ (match dim ((start end) (1+ end)) (end end)))
+
+(define (array-for-each1 proc array)
+ (cond
+ ((string? array)
+ (let lp ((n 0))
+ (when (< n (string-length array))
+ (proc (string-ref array n))
+ (lp (1+ n)))))
+ ((vector? array)
+ (let lp ((n 0))
+ (when (< n (vector-length array))
+ (proc (vector-ref array n))
+ (lp (1+ n)))))
+ ((bitvector? array)
+ (let lp ((n 0))
+ (when (< n (bitvector-length array))
+ (proc (bitvector-bit-set? array n))
+ (lp (1+ n)))))
+ ((bytevector? array)
+ (call-with-values (bytevector-accessors array)
+ (lambda (len ref set)
+ (let lp ((n 0))
+ (when (< n len)
+ (proc (ref n))
+ (lp (1+ n)))))))
+ (else
+ (let ((v (shared-array-root array)))
+ (define-values (length ref set) (compute-accessors v))
+ (match (array-shapev array)
+ (#() (proc (ref v (shared-array-offset array))))
+ (dims
+ (let ((ndims (vector-length dims)))
+ (let recur ((dim 0)
+ (offset (shared-array-offset array)))
+ (match (vector-ref dims dim)
+ (#(first count inc)
+ (if (eqv? dim (1- ndims))
+ (let lp ((i 0) (offset offset))
+ (when (< i count)
+ (proc (ref v offset))
+ (lp (1+ i) (+ offset inc))))
+ (let lp ((i 0) (offset offset))
+ (when (< i count)
+ (recur (1+ dim) offset)
+ (lp (1+ i) (+ offset inc)))))))))))))))
+
+(define (array-for-each* proc arrays)
+ (define shape (array-shapev (car arrays)))
+
+ (define src-count (length arrays))
+ (define src-advancev (make-vector src-count))
+ (define src-restorev (make-vector src-count))
+ (define src-readv (make-vector src-count))
+
+ (let lp ((i 0) (arrays arrays))
+ (match arrays
+ (() #t)
+ ((src . arrays)
+ (call-with-values (lambda () (prepare-reads shape src))
+ (lambda (read advance restore)
+ (vector-set! src-readv i read)
+ (vector-set! src-advancev i advance)
+ (vector-set! src-restorev i restore)))
+ (lp (1+ i) arrays))))
+
+ (define proc*
+ (match (vector-length src-readv)
+ (0 proc)
+ (1 (let ((read0 (vector-ref src-readv 0)))
+ (lambda () (proc (read0)))))
+ (2 (let ((read0 (vector-ref src-readv 0))
+ (read1 (vector-ref src-readv 1)))
+ (lambda () (proc (read0) (read1)))))
+ (n (let ((read0 (vector-ref src-readv 0))
+ (read1 (vector-ref src-readv 1))
+ (args (make-list (- n 2))))
+ (lambda ()
+ (let* ((v0 (read0))
+ (v1 (read1)))
+ (let lp ((i 2) (args args))
+ (let ((read (vector-ref src-readv i)))
+ (set-car! args (read))
+ (let ((i (1+ i)))
+ (when (< i n)
+ (lp i (cdr args))))))
+ (apply proc v0 v1 args)))))))
+
+ (define (advance-src-offsets! dim)
+ (let lp ((i 0))
+ (when (< i (vector-length src-advancev))
+ (let ((advance! (vector-ref src-advancev i)))
+ (advance! dim)
+ (lp (1+ i))))))
+
+ (define (restore-src-offsets! dim count)
+ (let lp ((i 0))
+ (when (< i (vector-length src-restorev))
+ (let ((restore! (vector-ref src-restorev i)))
+ (restore! dim count)
+ (lp (1+ i))))))
+
+ (cond
+ ((zero? (vector-length shape))
+ (proc*))
+ (else
+ (let recur ((dim 0))
+ (match (vector-ref shape dim)
+ (#(start count dst-inc)
+ (if (eq? (1+ dim) (vector-length shape))
+ (let lp ((n 0))
+ (cond
+ ((= n count)
+ (restore-src-offsets! dim count))
+ (else
+ (proc*)
+ (advance-src-offsets! dim)
+ (lp (1+ n)))))
+ (let lp ((n 0))
+ (cond
+ ((= n count)
+ (restore-src-offsets! dim count))
+ (else
+ (recur (1+ dim))
+ (advance-src-offsets! dim)
+ (lp (1+ n)))))))))))
+ *unspecified*)
+
+(define array-for-each
+ (case-lambda
+ ((proc array)
+ (array-for-each1 proc array))
+ ((proc array . arrays)
+ (array-for-each* proc (cons array arrays)))))
+
+(define (array-index-map! array proc)
+ "Apply @var{proc} to the indices of each element of @var{ra} in
+turn, storing the result in the corresponding element. The value
+returned and the order of application are unspecified.
+
+One can implement @var{array-indexes} as
+@lisp
+(define (array-indexes array)
+ (let ((ra (apply make-array #f (array-shape array))))
+ (array-index-map! ra (lambda x x))
+ ra))
+@end lisp
+Another example:
+@lisp
+(define (apl:index-generator n)
+ (let ((v (make-uniform-vector n 1)))
+ (array-index-map! v (lambda (i) i))
+ v))
+@end lisp"
+ (match (array-dimensions array)
+ (() (array-set! array (proc)))
+ ((dim)
+ (let lp ((n (dim-start dim)))
+ (unless (eqv? n (dim-end dim))
+ (array-set! array (proc n) n)
+ (lp (1+ n)))))
+ (dims
+ (let recur ((head '()) (dims dims))
+ (match dims
+ ((dim)
+ (let lp ((n (dim-start dim)))
+ (unless (eqv? n (dim-end dim))
+ (let ((idx (append head (list n))))
+ (apply array-set! array (apply proc idx) idx))
+ (lp (1+ n)))))
+ ((dim . dims)
+ (let lp ((n (dim-start dim)))
+ (unless (eqv? n (dim-end dim))
+ (recur (append head (list n)) dims)
+ (lp (1+ n))))))))))
+
+(define array-equal?
+ (case-lambda
+ "Return @code{#t} iff all arguments are arrays with the same
+shape, the same type, and have corresponding elements which are either
+@code{equal?} or @code{array-equal?}. This function differs from
+@code{equal?} in that all arguments must be arrays."
+ (() #t)
+ ((a) #t)
+ ((a b)
+ (define (slices-equal? a b dims)
+ (match dims
+ ((dim . dims)
+ (define (recur a b)
+ (if (null? dims)
+ (equal? a b)
+ (slices-equal? a b dims)))
+ (define (dim-start dim)
+ (match dim ((start end) start) (end 0)))
+ (define (dim-end dim)
+ (match dim ((start end) end) (end end)))
+ (let lp ((n (dim-start dim)))
+ (or (eqv? n (dim-end dim))
+ (and (recur (array-cell-ref a n)
+ (array-cell-ref b n))
+ (lp (1+ n))))))))
+
+ (and (equal? (array-dimensions a) (array-dimensions b))
+ (match (array-type a)
+ ((or 'vu8 'u8)
+ ;; R6RS and Guile mostly use #vu8(...) as the literal syntax
+ ;; for bytevectors, but R7RS uses #u8. To allow R7RS users
+ ;; to re-use the various routines implemented on bytevectors
+ ;; which return vu8-tagged values and to also be able to do
+ ;; (equal? #u8(1 2 3) (bytevector 1 2 3)), we allow equality
+ ;; comparisons between vu8 and u8.
+ (match (array-type b)
+ ((or 'vu8 'u8) #t)
+ (_ #f)))
+ (ta (eq? ta (array-type b))))
+ (if (zero? (array-rank a))
+ (equal? (array-ref a) (array-ref b))
+ (slices-equal? a b (array-dimensions a)))))
+
+ ((a b . rest)
+ (and (array-equal? a b)
+ (apply array-equal? b rest)))))
+
+(define (array-slice-for-each frame-rank proc . arrays)
+ "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}
+of the arrays @var{args}, in unspecified order. The first
+@var{frame-rank} dimensions of each @var{arg} must match. Rank-0 cells
+are passed as rank-0 arrays. The value returned is unspecified.
+
+For example:
+@lisp
+;; Sort the rows of rank-2 array A.
+(array-slice-for-each 1 (lambda (x) (sort! x <)) a)
+
+;; Compute the arguments of the (x y) vectors in the rows of rank-2
+;; array XYS and store them in rank-1 array ANGLES. Inside OP,
+;; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.
+
+(array-slice-for-each 1
+ (lambda (xy angle)
+ (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))
+ xys angles)
+@end lisp"
+ (match arrays
+ (() (values))
+ ((head tail ...)
+ (let ((dims (array-dimensions head)))
+ (unless (<= frame-rank (length dims))
+ (error "frame too large for argument" frame-rank head))
+ (define frame-dims (list-head dims frame-rank))
+ (for-each (lambda (array)
+ (define dims (array-dimensions array))
+ (unless (<= frame-rank (length dims))
+ (error "frame too large for argument" frame-rank array))
+ (unless (equal? (list-head dims frame-rank) frame-dims)
+ (error "mismatched frames" frame-dims array)))
+ tail)
+ (let recur ((arrays arrays)
+ (frame-dims frame-dims))
+ (match frame-dims
+ (()
+ (apply proc arrays))
+ ((dim . frame-dims)
+ (let slice ((n (dim-start dim)))
+ (when (< n (dim-end dim))
+ (recur (map (lambda (array) (array-slice array n)) arrays)
+ frame-dims)
+ (slice (1+ n))))))))))
+ *unspecified*)
+
+(define (array-slice-for-each-in-order frame-rank proc . arrays)
+ "Same as array-slice-for-each, but visit the cells sequentially
+and in row-major order."
+ (apply array-slice-for-each frame-rank proc arrays))
+
+(define (array-cell-ref array . indices)
+ "Return the element at the @code{(@var{indices} ...)} position
+in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]
+if the rank of @var{ra} is larger than the number of indices.
+
+See also @code{array-ref}, @code{array-slice}, @code{array-cell-set!}.
+
+@code{array-cell-ref} never returns a rank 0 array. For example:
+@lisp
+(array-cell-ref #2((1 2 3) (4 5 6)) 1 1) @result{} 5
+(array-cell-ref #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)
+(array-cell-ref #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))
+(array-cell-ref #0(5) @result{} 5.
+@end lisp"
+ (if (= (length indices) (array-rank array))
+ (apply array-ref array indices)
+ (apply array-slice array indices)))
+
+(define (array-cell-set! array val . indices)
+ "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}.
+
+Equivalent to @code{(array-copy! @var{b} (apply array-cell-ref @var{ra}
+@var{indices}))} if the number of indices is smaller than the rank of
+@var{ra}; otherwise equivalent to @code{(apply array-set! @var{ra}
+@var{b} @var{indices})}. This function returns the modified array
+@var{ra}.
+
+See also @code{array-ref}, @code{array-cell-ref}, @code{array-slice}.
+
+For example:
+@lisp
+(define A (list->array 2 '((1 2 3) (4 5 6))))
+(array-cell-set! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))
+(array-cell-set! A 99 1 1) @result{} #2((1 2 3) (4 99 6))
+(array-cell-set! A #(a b c) 0) @result{} #2((a b c) (4 99 6))
+(array-cell-set! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))
+
+(define B (make-array 0))
+(array-cell-set! B 15) @result{} #0(15)
+@end lisp"
+ (if (= (length indices) (array-rank array))
+ (apply array-set! array val indices)
+ (array-copy! val (apply array-slice array indices)))
+ array)
+
;; Printing arrays
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 6ff24c4c6..75f0e48a0 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -20,6 +20,7 @@
#:use-module (ice-9 object-properties)
#:use-module (ice-9 source-properties)
#:use-module (ice-9 weak-tables)
+ #:use-module (ice-9 arrays)
#:export ((make-guardian* . make-guardian)
module-observe-weak
(make-object-property* . make-object-property)
@@ -34,7 +35,16 @@
(set-source-properties!* . set-source-properties!)
(source-property* . source-property)
(set-source-properties* . set-source-property!)
- (cons-source* . cons-source)))
+ (cons-source* . cons-source)
+ (array-fill!* . array-fill!)
+ (array-copy!* . array-copy!)
+ (array-copy-in-order!* . array-copy-in-order!)
+ (array-map!* . array-map!)
+ (array-for-each* . array-for-each)
+ (array-index-map!* . array-index-map!)
+ (array-equal?* . array-equal?)
+ (array-slice-for-each* . array-slice-for-each)
+ (array-slice-for-each-in-order* . array-slice-for-each-in-order)))
#;
(define-syntax-rule (define-deprecated name message exp)
@@ -158,3 +168,69 @@ Import it from (ice-9 source-properties) instead.")
"cons-source in the default environment is deprecated.
Import it from (ice-9 source-properties) instead.")
(cons-source orig x y))
+
+(define (array-fill!* array fill)
+ (issue-deprecation-warning
+ "array-fill! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (array-fill! array fill))
+
+(define (array-copy!* src dst)
+ (issue-deprecation-warning
+ "array-copy! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (array-copy! src dst))
+
+(define (array-copy-in-order!* src dst)
+ (issue-deprecation-warning
+ "array-copy-in-order! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (array-copy-in-order! src dst))
+
+(define (array-map!* dst proc . src*)
+ (issue-deprecation-warning
+ "array-map! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-map! dst proc src*))
+
+(define (array-for-each* proc array . arrays)
+ (issue-deprecation-warning
+ "array-for-each in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-for-each proc array arrays))
+
+(define (array-index-map!* array proc)
+ (issue-deprecation-warning
+ "array-index-map! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (array-index-map! array proc))
+
+(define (array-equal?* . arrays)
+ (issue-deprecation-warning
+ "array-equal? in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-equal? arrays))
+
+(define (array-slice-for-each* frame-rank proc . arrays)
+ (issue-deprecation-warning
+ "array-slice-for-each in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-slice-for-each frame-rank proc arrays))
+
+(define (array-slice-for-each-in-order* frame-rank proc . arrays)
+ (issue-deprecation-warning
+ "array-slice-for-each-in-order in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-slice-for-each-in-order frame-rank proc arrays))
+
+(define (array-cell-ref* array . indices)
+ (issue-deprecation-warning
+ "array-cell-ref in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-cell-ref array indices))
+
+(define (array-cell-set!* array val . indices)
+ (issue-deprecation-warning
+ "array-cell-set! in the default environment is deprecated.
+Import it from (ice-9 arrays) instead.")
+ (apply array-cell-set! array val indices))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 4bc951ebf..3007afda1 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,7 +1,7 @@
;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010,
-;;;; 2012, 2013, 2014, 2023 Free Software Foundation, Inc.
+;;;; 2012, 2013, 2014, 2023, 2025 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 soft-ports)
#:use-module (ice-9 textual-ports)
+ #:use-module (ice-9 arrays)
#:export (pretty-print
truncated-print))
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 6dda93eac..24df57864 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -21,6 +21,7 @@
(define-module (oop goops save)
#:use-module (ice-9 copy-tree)
#:use-module (ice-9 weak-tables)
+ #:use-module (ice-9 arrays)
#:use-module (oop goops internal)
#:export (make-unbound save-objects load-objects restore
enumerate! enumerate-component!
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
index 25b4aaa9d..a55f1fd73 100644
--- a/test-suite/tests/array-map.test
+++ b/test-suite/tests/array-map.test
@@ -1,6 +1,6 @@
;;;; array-map.test --- test array mapping functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013, 2025 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,7 +17,8 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-array-map)
- #:use-module (test-suite lib))
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 arrays))
(define exception:shape-mismatch
(cons 'misc-error ".*shape mismatch.*"))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 3bf433582..edc5e28a8 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,6 +1,6 @@
;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
-;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free
+;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2025 Free
;;;; Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -20,6 +20,7 @@
(define-module (test-suite test-arrays)
#:use-module ((system base compile) #:select (compile))
#:use-module (test-suite lib)
+ #:use-module (ice-9 arrays)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-4 gnu))
@@ -656,7 +657,7 @@
(array-fill! a 128))
(pass-if-exception "-129" exception:out-of-range
(array-fill! a -129))
- (pass-if-exception "symbol" exception:wrong-type-arg
+ (pass-if-exception "symbol" exception:out-of-range
(array-fill! a 'symbol))))
(with-test-prefix "short"
