mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
e7efe8e793
* libguile/root.h * libguile/root.c (scm_sys_protects): It used to be that for some reason we'd define a special array of "protected" values. This was a little silly, always, but with the BDW GC it's completely unnecessary. Also many of these variables were unused, and none of them were good API. So remove this array, and either eliminate, make static, or make internal the various values. * libguile/snarf.h: No need to generate calls to scm_permanent_object. * guile-readline/readline.c (scm_init_readline): No need to call scm_permanent_object. * libguile/array-map.c (ramap, rafe): Remove the dubious nullvect optimizations. * libguile/async.c (scm_init_async): No need to init scm_asyncs, it is no more. * libguile/eval.c (scm_init_eval): No need to init scm_listofnull, it is no more. * libguile/gc.c: Make scm_protects a static var. (scm_storage_prehistory): Change the sanity check to use the address of protects. (scm_init_gc_protect_object): No need to clear the scm_sys_protects, as it is no more. * libguile/keywords.c: Make the keyword obarray a static var. * libguile/numbers.c: Make flo0 a static var. * libguile/objprop.c: Make object_whash a static var. * libguile/properties.c: Make properties_whash a static var. * libguile/srcprop.h: * libguile/srcprop.c: Make scm_source_whash a global with internal linkage. * libguile/strings.h: * libguile/strings.c: Make scm_nullstr a global with internal linkage. * libguile/vectors.c (scm_init_vectors): No need to init scm_nullvect, it's unused.
970 lines
24 KiB
C
970 lines
24 KiB
C
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009 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 License
|
||
* as published by the Free Software Foundation; either version 3 of
|
||
* the License, or (at your option) any later version.
|
||
*
|
||
* This library 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 this library; if not, write to the Free Software
|
||
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
||
* 02110-1301 USA
|
||
*/
|
||
|
||
|
||
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include "libguile/_scm.h"
|
||
#include "libguile/strings.h"
|
||
#include "libguile/arrays.h"
|
||
#include "libguile/smob.h"
|
||
#include "libguile/chars.h"
|
||
#include "libguile/eq.h"
|
||
#include "libguile/eval.h"
|
||
#include "libguile/feature.h"
|
||
#include "libguile/root.h"
|
||
#include "libguile/vectors.h"
|
||
#include "libguile/bitvectors.h"
|
||
#include "libguile/srfi-4.h"
|
||
#include "libguile/generalized-arrays.h"
|
||
#include "libguile/generalized-vectors.h"
|
||
|
||
#include "libguile/validate.h"
|
||
#include "libguile/array-map.h"
|
||
|
||
|
||
/* The WHAT argument for `scm_gc_malloc ()' et al. */
|
||
static const char indices_gc_hint[] = "array-indices";
|
||
|
||
|
||
#define GVREF scm_c_generalized_vector_ref
|
||
#define GVSET scm_c_generalized_vector_set_x
|
||
|
||
static unsigned long
|
||
cind (SCM ra, long *ve)
|
||
{
|
||
unsigned long i;
|
||
int k;
|
||
if (!SCM_I_ARRAYP (ra))
|
||
return *ve;
|
||
i = SCM_I_ARRAY_BASE (ra);
|
||
for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
|
||
i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
|
||
return i;
|
||
}
|
||
|
||
|
||
/* Checker for scm_array mapping functions:
|
||
return values: 4 --> shapes, increments, and bases are the same;
|
||
3 --> shapes and increments are the same;
|
||
2 --> shapes are the same;
|
||
1 --> ras are at least as big as ra0;
|
||
0 --> no match.
|
||
*/
|
||
|
||
int
|
||
scm_ra_matchp (SCM ra0, SCM ras)
|
||
{
|
||
SCM ra1;
|
||
scm_t_array_dim dims;
|
||
scm_t_array_dim *s0 = &dims;
|
||
scm_t_array_dim *s1;
|
||
unsigned long bas0 = 0;
|
||
int i, ndim = 1;
|
||
int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
|
||
|
||
if (scm_is_generalized_vector (ra0))
|
||
{
|
||
s0->lbnd = 0;
|
||
s0->inc = 1;
|
||
s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
|
||
}
|
||
else if (SCM_I_ARRAYP (ra0))
|
||
{
|
||
ndim = SCM_I_ARRAY_NDIM (ra0);
|
||
s0 = SCM_I_ARRAY_DIMS (ra0);
|
||
bas0 = SCM_I_ARRAY_BASE (ra0);
|
||
}
|
||
else
|
||
return 0;
|
||
|
||
while (SCM_NIMP (ras))
|
||
{
|
||
ra1 = SCM_CAR (ras);
|
||
|
||
if (scm_is_generalized_vector (ra1))
|
||
{
|
||
size_t length;
|
||
|
||
if (1 != ndim)
|
||
return 0;
|
||
|
||
length = scm_c_generalized_vector_length (ra1);
|
||
|
||
switch (exact)
|
||
{
|
||
case 4:
|
||
if (0 != bas0)
|
||
exact = 3;
|
||
case 3:
|
||
if (1 != s0->inc)
|
||
exact = 2;
|
||
case 2:
|
||
if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
|
||
break;
|
||
exact = 1;
|
||
case 1:
|
||
if (s0->lbnd < 0 || s0->ubnd >= length)
|
||
return 0;
|
||
}
|
||
}
|
||
else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
|
||
{
|
||
s1 = SCM_I_ARRAY_DIMS (ra1);
|
||
if (bas0 != SCM_I_ARRAY_BASE (ra1))
|
||
exact = 3;
|
||
for (i = 0; i < ndim; i++)
|
||
switch (exact)
|
||
{
|
||
case 4:
|
||
case 3:
|
||
if (s0[i].inc != s1[i].inc)
|
||
exact = 2;
|
||
case 2:
|
||
if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
|
||
break;
|
||
exact = 1;
|
||
default:
|
||
if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
|
||
return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
|
||
}
|
||
}
|
||
else
|
||
return 0;
|
||
|
||
ras = SCM_CDR (ras);
|
||
}
|
||
|
||
return exact;
|
||
}
|
||
|
||
/* 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. */
|
||
int
|
||
scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
|
||
{
|
||
SCM z;
|
||
SCM vra0, ra1, vra1;
|
||
SCM lvra, *plvra;
|
||
long *vinds;
|
||
int k, kmax;
|
||
switch (scm_ra_matchp (ra0, lra))
|
||
{
|
||
default:
|
||
case 0:
|
||
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
||
case 2:
|
||
case 3:
|
||
case 4: /* Try unrolling arrays */
|
||
kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
|
||
if (kmax < 0)
|
||
goto gencase;
|
||
vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
|
||
if (SCM_IMP (vra0)) goto gencase;
|
||
if (!SCM_I_ARRAYP (vra0))
|
||
{
|
||
size_t length = scm_c_generalized_vector_length (vra0);
|
||
vra1 = scm_i_make_array (1);
|
||
SCM_I_ARRAY_BASE (vra1) = 0;
|
||
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
|
||
SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
|
||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||
SCM_I_ARRAY_V (vra1) = vra0;
|
||
vra0 = vra1;
|
||
}
|
||
lvra = SCM_EOL;
|
||
plvra = &lvra;
|
||
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
|
||
{
|
||
ra1 = SCM_CAR (z);
|
||
vra1 = scm_i_make_array (1);
|
||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||
if (!SCM_I_ARRAYP (ra1))
|
||
{
|
||
SCM_I_ARRAY_BASE (vra1) = 0;
|
||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||
SCM_I_ARRAY_V (vra1) = ra1;
|
||
}
|
||
else if (!SCM_I_ARRAY_CONTP (ra1))
|
||
goto gencase;
|
||
else
|
||
{
|
||
SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
|
||
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
||
}
|
||
*plvra = scm_cons (vra1, SCM_EOL);
|
||
plvra = SCM_CDRLOC (*plvra);
|
||
}
|
||
return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
|
||
case 1:
|
||
gencase: /* Have to loop over all dimensions. */
|
||
vra0 = scm_i_make_array (1);
|
||
if (SCM_I_ARRAYP (ra0))
|
||
{
|
||
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
|
||
if (kmax < 0)
|
||
{
|
||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||
SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
|
||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||
}
|
||
else
|
||
{
|
||
SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
|
||
SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
|
||
SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
|
||
}
|
||
SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
|
||
SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
|
||
}
|
||
else
|
||
{
|
||
size_t length = scm_c_generalized_vector_length (ra0);
|
||
kmax = 0;
|
||
SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
|
||
SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
|
||
SCM_I_ARRAY_DIMS (vra0)->inc = 1;
|
||
SCM_I_ARRAY_BASE (vra0) = 0;
|
||
SCM_I_ARRAY_V (vra0) = ra0;
|
||
ra0 = vra0;
|
||
}
|
||
lvra = SCM_EOL;
|
||
plvra = &lvra;
|
||
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
|
||
{
|
||
ra1 = SCM_CAR (z);
|
||
vra1 = scm_i_make_array (1);
|
||
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
|
||
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
|
||
if (SCM_I_ARRAYP (ra1))
|
||
{
|
||
if (kmax >= 0)
|
||
SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||
SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
|
||
}
|
||
else
|
||
{
|
||
SCM_I_ARRAY_DIMS (vra1)->inc = 1;
|
||
SCM_I_ARRAY_V (vra1) = ra1;
|
||
}
|
||
*plvra = scm_cons (vra1, SCM_EOL);
|
||
plvra = SCM_CDRLOC (*plvra);
|
||
}
|
||
|
||
vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
|
||
indices_gc_hint);
|
||
|
||
for (k = 0; k <= kmax; k++)
|
||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
|
||
k = kmax;
|
||
do
|
||
{
|
||
if (k == kmax)
|
||
{
|
||
SCM y = lra;
|
||
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
|
||
for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
||
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
|
||
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
|
||
return 0;
|
||
k--;
|
||
continue;
|
||
}
|
||
if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
||
{
|
||
vinds[k]++;
|
||
k++;
|
||
continue;
|
||
}
|
||
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
||
k--;
|
||
}
|
||
while (k >= 0);
|
||
|
||
return 1;
|
||
}
|
||
}
|
||
|
||
|
||
SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
|
||
(SCM ra, SCM fill),
|
||
"Store @var{fill} in every element of @var{array}. The value returned\n"
|
||
"is unspecified.")
|
||
#define FUNC_NAME s_scm_array_fill_x
|
||
{
|
||
scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
/* to be used as cproc in scm_ramapc to fill an array dimension with
|
||
"fill". */
|
||
int
|
||
scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
|
||
#define FUNC_NAME s_scm_array_fill_x
|
||
{
|
||
unsigned long i;
|
||
unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
|
||
long inc = SCM_I_ARRAY_DIMS (ra)->inc;
|
||
unsigned long base = SCM_I_ARRAY_BASE (ra);
|
||
|
||
ra = SCM_I_ARRAY_V (ra);
|
||
|
||
for (i = base; n--; i += inc)
|
||
GVSET (ra, i, fill);
|
||
|
||
return 1;
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
static int
|
||
racp (SCM src, SCM dst)
|
||
{
|
||
long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
|
||
long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
|
||
unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
|
||
dst = SCM_CAR (dst);
|
||
inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
|
||
i_d = SCM_I_ARRAY_BASE (dst);
|
||
src = SCM_I_ARRAY_V (src);
|
||
dst = SCM_I_ARRAY_V (dst);
|
||
|
||
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
|
||
GVSET (dst, i_d, GVREF (src, i_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{source} to the\n"
|
||
"corresponding element of @var{destination}. @var{destination} must have\n"
|
||
"the same rank as @var{source}, 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
|
||
|
||
/* Functions callable by ARRAY-MAP! */
|
||
|
||
|
||
int
|
||
scm_ra_eqp (SCM ra0, SCM ras)
|
||
{
|
||
SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
|
||
scm_t_array_handle ra0_handle;
|
||
scm_t_array_dim *ra0_dims;
|
||
size_t n;
|
||
ssize_t inc0;
|
||
size_t i0 = 0;
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
ra2 = SCM_I_ARRAY_V (ra2);
|
||
|
||
scm_array_get_handle (ra0, &ra0_handle);
|
||
ra0_dims = scm_array_handle_dims (&ra0_handle);
|
||
n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
|
||
inc0 = ra0_dims[0].inc;
|
||
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
|
||
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
|
||
if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
|
||
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
|
||
}
|
||
|
||
scm_array_handle_release (&ra0_handle);
|
||
return 1;
|
||
}
|
||
|
||
/* opt 0 means <, nonzero means >= */
|
||
|
||
static int
|
||
ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
|
||
{
|
||
scm_t_array_handle ra0_handle;
|
||
scm_t_array_dim *ra0_dims;
|
||
size_t n;
|
||
ssize_t inc0;
|
||
size_t i0 = 0;
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
ra2 = SCM_I_ARRAY_V (ra2);
|
||
|
||
scm_array_get_handle (ra0, &ra0_handle);
|
||
ra0_dims = scm_array_handle_dims (&ra0_handle);
|
||
n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
|
||
inc0 = ra0_dims[0].inc;
|
||
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
|
||
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
|
||
if (opt ?
|
||
scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
|
||
scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
|
||
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
|
||
}
|
||
|
||
scm_array_handle_release (&ra0_handle);
|
||
return 1;
|
||
}
|
||
|
||
|
||
|
||
int
|
||
scm_ra_lessp (SCM ra0, SCM ras)
|
||
{
|
||
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
|
||
}
|
||
|
||
|
||
int
|
||
scm_ra_leqp (SCM ra0, SCM ras)
|
||
{
|
||
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
|
||
}
|
||
|
||
|
||
int
|
||
scm_ra_grp (SCM ra0, SCM ras)
|
||
{
|
||
return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
|
||
}
|
||
|
||
|
||
int
|
||
scm_ra_greqp (SCM ra0, SCM ras)
|
||
{
|
||
return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
|
||
}
|
||
|
||
|
||
int
|
||
scm_ra_sum (SCM ra0, SCM ras)
|
||
{
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
|
||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (!scm_is_null(ras))
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||
GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
|
||
|
||
int
|
||
scm_ra_difference (SCM ra0, SCM ras)
|
||
{
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
|
||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (scm_is_null (ras))
|
||
{
|
||
switch (SCM_TYP7 (ra0))
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0)
|
||
GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
else
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||
GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
|
||
GVREF (ra1, i1)));
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
|
||
|
||
int
|
||
scm_ra_product (SCM ra0, SCM ras)
|
||
{
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
|
||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (!scm_is_null (ras))
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||
GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
|
||
GVREF (ra1, i1)));
|
||
}
|
||
}
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
|
||
int
|
||
scm_ra_divide (SCM ra0, SCM ras)
|
||
{
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
|
||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (scm_is_null (ras))
|
||
{
|
||
switch (SCM_TYP7 (ra0))
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0)
|
||
GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
else
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
|
||
{
|
||
default:
|
||
{
|
||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||
{
|
||
SCM res = scm_divide (GVREF (ra0, i0),
|
||
GVREF (ra1, i1));
|
||
GVSET (ra0, i0, res);
|
||
}
|
||
break;
|
||
}
|
||
}
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
|
||
int
|
||
scm_array_identity (SCM dst, SCM src)
|
||
{
|
||
return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
|
||
}
|
||
|
||
|
||
|
||
static int
|
||
ramap (SCM ra0, SCM proc, SCM ras)
|
||
{
|
||
long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
|
||
long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
|
||
long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (scm_is_null (ras))
|
||
for (; i <= n; i++)
|
||
GVSET (ra0, i*inc+base, scm_call_0 (proc));
|
||
else
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
SCM args;
|
||
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
ras = scm_vector (SCM_CDR (ras));
|
||
|
||
for (; i <= n; i++, i1 += inc1)
|
||
{
|
||
args = SCM_EOL;
|
||
for (k = scm_c_vector_length (ras); k--;)
|
||
args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
|
||
args = scm_cons (GVREF (ra1, i1), args);
|
||
GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
|
||
}
|
||
}
|
||
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 as\n"
|
||
"@var{array0} and have a range for each index which includes the range\n"
|
||
"for the corresponding index in @var{array0}. @var{proc} is applied to\n"
|
||
"each tuple of elements of @var{array1} @dots{} and the result is stored\n"
|
||
"as the corresponding element in @var{array0}. The value returned is\n"
|
||
"unspecified. The order of application is 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)
|
||
{
|
||
long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
|
||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
|
||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
if (scm_is_null (ras))
|
||
for (; i <= n; i++, i0 += inc0)
|
||
scm_call_1 (proc, GVREF (ra0, i0));
|
||
else
|
||
{
|
||
SCM ra1 = SCM_CAR (ras);
|
||
SCM args;
|
||
unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
|
||
long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
ras = scm_vector (SCM_CDR (ras));
|
||
|
||
for (; i <= n; i++, i0 += inc0, i1 += inc1)
|
||
{
|
||
args = SCM_EOL;
|
||
for (k = scm_c_vector_length (ras); k--;)
|
||
args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
|
||
args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
|
||
scm_apply_0 (proc, args);
|
||
}
|
||
}
|
||
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{array0} @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
|
||
|
||
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{array} 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
|
||
{
|
||
unsigned long i;
|
||
SCM_VALIDATE_PROC (2, proc);
|
||
|
||
if (SCM_I_ARRAYP (ra))
|
||
{
|
||
SCM args = SCM_EOL;
|
||
int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
|
||
long *vinds;
|
||
|
||
if (kmax < 0)
|
||
return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
|
||
|
||
vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
|
||
indices_gc_hint);
|
||
|
||
for (k = 0; k <= kmax; k++)
|
||
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
|
||
k = kmax;
|
||
do
|
||
{
|
||
if (k == kmax)
|
||
{
|
||
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
|
||
i = cind (ra, vinds);
|
||
for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
|
||
{
|
||
for (j = kmax + 1, args = SCM_EOL; j--;)
|
||
args = scm_cons (scm_from_long (vinds[j]), args);
|
||
GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
|
||
i += SCM_I_ARRAY_DIMS (ra)[k].inc;
|
||
}
|
||
k--;
|
||
continue;
|
||
}
|
||
if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
|
||
{
|
||
vinds[k]++;
|
||
k++;
|
||
continue;
|
||
}
|
||
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
|
||
k--;
|
||
}
|
||
while (k >= 0);
|
||
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
else if (scm_is_generalized_vector (ra))
|
||
{
|
||
size_t length = scm_c_generalized_vector_length (ra);
|
||
for (i = 0; i < length; i++)
|
||
GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
else
|
||
scm_wrong_type_arg_msg (NULL, 0, ra, "array");
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
static int
|
||
raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
|
||
{
|
||
unsigned long i0 = 0, i1 = 0;
|
||
long inc0 = 1, inc1 = 1;
|
||
unsigned long n;
|
||
ra1 = SCM_CAR (ra1);
|
||
if (SCM_I_ARRAYP(ra0))
|
||
{
|
||
n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||
i0 = SCM_I_ARRAY_BASE (ra0);
|
||
inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
|
||
ra0 = SCM_I_ARRAY_V (ra0);
|
||
}
|
||
else
|
||
n = scm_c_generalized_vector_length (ra0);
|
||
|
||
if (SCM_I_ARRAYP (ra1))
|
||
{
|
||
i1 = SCM_I_ARRAY_BASE (ra1);
|
||
inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||
ra1 = SCM_I_ARRAY_V (ra1);
|
||
}
|
||
|
||
if (scm_is_generalized_vector (ra0))
|
||
{
|
||
for (; n--; i0 += inc0, i1 += inc1)
|
||
{
|
||
if (scm_is_false (as_equal))
|
||
{
|
||
if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
|
||
return 0;
|
||
}
|
||
else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
|
||
return 0;
|
||
}
|
||
return 1;
|
||
}
|
||
else
|
||
return 0;
|
||
}
|
||
|
||
|
||
|
||
static int
|
||
raeql (SCM ra0, SCM as_equal, SCM ra1)
|
||
{
|
||
SCM v0 = ra0, v1 = ra1;
|
||
scm_t_array_dim dim0, dim1;
|
||
scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
|
||
unsigned long bas0 = 0, bas1 = 0;
|
||
int k, unroll = 1, vlen = 1, ndim = 1;
|
||
if (SCM_I_ARRAYP (ra0))
|
||
{
|
||
ndim = SCM_I_ARRAY_NDIM (ra0);
|
||
s0 = SCM_I_ARRAY_DIMS (ra0);
|
||
bas0 = SCM_I_ARRAY_BASE (ra0);
|
||
v0 = SCM_I_ARRAY_V (ra0);
|
||
}
|
||
else
|
||
{
|
||
s0->inc = 1;
|
||
s0->lbnd = 0;
|
||
s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
|
||
unroll = 0;
|
||
}
|
||
if (SCM_I_ARRAYP (ra1))
|
||
{
|
||
if (ndim != SCM_I_ARRAY_NDIM (ra1))
|
||
return 0;
|
||
s1 = SCM_I_ARRAY_DIMS (ra1);
|
||
bas1 = SCM_I_ARRAY_BASE (ra1);
|
||
v1 = SCM_I_ARRAY_V (ra1);
|
||
}
|
||
else
|
||
{
|
||
/*
|
||
Huh ? Schizophrenic return type. --hwn
|
||
*/
|
||
if (1 != ndim)
|
||
return 0;
|
||
s1->inc = 1;
|
||
s1->lbnd = 0;
|
||
s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
|
||
unroll = 0;
|
||
}
|
||
if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
|
||
return 0;
|
||
for (k = ndim; k--;)
|
||
{
|
||
if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
|
||
return 0;
|
||
if (unroll)
|
||
{
|
||
unroll = (s0[k].inc == s1[k].inc);
|
||
vlen *= s0[k].ubnd - s1[k].lbnd + 1;
|
||
}
|
||
}
|
||
if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
|
||
return 1;
|
||
return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
|
||
}
|
||
|
||
|
||
SCM
|
||
scm_raequal (SCM ra0, SCM ra1)
|
||
{
|
||
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
|
||
}
|
||
|
||
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 a one dimensional shared\n"
|
||
"array may be @var{array-equal?} but not @var{equal?} to a\n"
|
||
"vector or uniform vector.")
|
||
#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
|
||
|
||
|
||
SCM
|
||
scm_array_equal_p (SCM ra0, SCM ra1)
|
||
{
|
||
if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
|
||
return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
|
||
return scm_equal_p (ra0, ra1);
|
||
}
|
||
|
||
|
||
void
|
||
scm_init_array_map (void)
|
||
{
|
||
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
|
||
#include "libguile/array-map.x"
|
||
scm_add_feature (s_scm_array_for_each);
|
||
}
|
||
|
||
/*
|
||
Local Variables:
|
||
c-file-style: "gnu"
|
||
End:
|
||
*/
|