Deprecate dead code in array-map.c
[bpt/guile.git] / libguile / array-map.c
CommitLineData
72e2b592
DL
1/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
2 * 2010, 2012, 2013 Free Software Foundation, Inc.
3 *
73be1d9e 4 * This library is free software; you can redistribute it and/or
53befeb7
NJ
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
0f2d19dd 8 *
53befeb7
NJ
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
0f2d19dd 13 *
73be1d9e
MV
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
53befeb7
NJ
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
73be1d9e 18 */
1bbd0b84 19
1bbd0b84 20
0f2d19dd
JB
21\f
22
23
24\f
dbb605f5
LC
25#ifdef HAVE_CONFIG_H
26# include <config.h>
27#endif
0f2d19dd 28
a0599745 29#include "libguile/_scm.h"
405aaef9 30#include "libguile/strings.h"
2fa901a5 31#include "libguile/arrays.h"
a0599745
MD
32#include "libguile/smob.h"
33#include "libguile/chars.h"
34#include "libguile/eq.h"
35#include "libguile/eval.h"
36#include "libguile/feature.h"
37#include "libguile/root.h"
38#include "libguile/vectors.h"
cf396142 39#include "libguile/bitvectors.h"
b4bdadde 40#include "libguile/srfi-4.h"
1030b450 41#include "libguile/generalized-arrays.h"
f332e957 42#include "libguile/generalized-vectors.h"
a0599745
MD
43
44#include "libguile/validate.h"
5d1b3b2d 45#include "libguile/array-map.h"
0f2d19dd
JB
46\f
47
d66b74dc
LC
48/* The WHAT argument for `scm_gc_malloc ()' et al. */
49static const char indices_gc_hint[] = "array-indices";
50
0f2d19dd 51
85516012
MV
52#define GVREF scm_c_generalized_vector_ref
53#define GVSET scm_c_generalized_vector_set_x
c209c88e 54
c014a02e 55static unsigned long
b4b33636 56cind (SCM ra, long *ve)
0f2d19dd 57{
c014a02e 58 unsigned long i;
0f2d19dd 59 int k;
04b87de5 60 if (!SCM_I_ARRAYP (ra))
0f2d19dd 61 return *ve;
04b87de5
MV
62 i = SCM_I_ARRAY_BASE (ra);
63 for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
64 i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
0f2d19dd
JB
65 return i;
66}
67
68
69/* Checker for scm_array mapping functions:
70 return values: 4 --> shapes, increments, and bases are the same;
71 3 --> shapes and increments are the same;
72 2 --> shapes are the same;
73 1 --> ras are at least as big as ra0;
74 0 --> no match.
75 */
1cc91f1b 76
0f2d19dd 77int
6e8d25a6 78scm_ra_matchp (SCM ra0, SCM ras)
0f2d19dd
JB
79{
80 SCM ra1;
92c2555f
MV
81 scm_t_array_dim dims;
82 scm_t_array_dim *s0 = &dims;
83 scm_t_array_dim *s1;
c014a02e 84 unsigned long bas0 = 0;
0f2d19dd 85 int i, ndim = 1;
399aba0a
MV
86 int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
87
88 if (scm_is_generalized_vector (ra0))
c209c88e 89 {
c209c88e
GB
90 s0->lbnd = 0;
91 s0->inc = 1;
399aba0a
MV
92 s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
93 }
04b87de5 94 else if (SCM_I_ARRAYP (ra0))
399aba0a 95 {
04b87de5
MV
96 ndim = SCM_I_ARRAY_NDIM (ra0);
97 s0 = SCM_I_ARRAY_DIMS (ra0);
98 bas0 = SCM_I_ARRAY_BASE (ra0);
c209c88e 99 }
399aba0a
MV
100 else
101 return 0;
102
368cf54d 103 while (SCM_NIMP (ras))
c209c88e
GB
104 {
105 ra1 = SCM_CAR (ras);
399aba0a
MV
106
107 if (scm_is_generalized_vector (ra1))
c209c88e 108 {
399aba0a
MV
109 size_t length;
110
111 if (1 != ndim)
c209c88e 112 return 0;
399aba0a
MV
113
114 length = scm_c_generalized_vector_length (ra1);
115
116 switch (exact)
117 {
118 case 4:
119 if (0 != bas0)
120 exact = 3;
121 case 3:
122 if (1 != s0->inc)
123 exact = 2;
124 case 2:
125 if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
126 break;
127 exact = 1;
128 case 1:
129 if (s0->lbnd < 0 || s0->ubnd >= length)
130 return 0;
131 }
132 }
04b87de5 133 else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
399aba0a 134 {
04b87de5
MV
135 s1 = SCM_I_ARRAY_DIMS (ra1);
136 if (bas0 != SCM_I_ARRAY_BASE (ra1))
c209c88e
GB
137 exact = 3;
138 for (i = 0; i < ndim; i++)
139 switch (exact)
140 {
141 case 4:
142 case 3:
143 if (s0[i].inc != s1[i].inc)
144 exact = 2;
145 case 2:
146 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
147 break;
148 exact = 1;
149 default:
150 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
151 return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
152 }
c209c88e 153 }
399aba0a
MV
154 else
155 return 0;
156
c209c88e
GB
157 ras = SCM_CDR (ras);
158 }
399aba0a 159
0f2d19dd
JB
160 return exact;
161}
162
1bbd0b84
GB
163/* array mapper: apply cproc to each dimension of the given arrays?.
164 int (*cproc) (); procedure to call on unrolled arrays?
5c11cc9d 165 cproc (dest, source list) or
1bbd0b84
GB
166 cproc (dest, data, source list).
167 SCM data; data to give to cproc or unbound.
168 SCM ra0; destination array.
169 SCM lra; list of source arrays.
170 const char *what; caller, for error reporting. */
171int
10b9343f 172scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
0f2d19dd 173{
b4b33636 174 SCM z;
0f2d19dd
JB
175 SCM vra0, ra1, vra1;
176 SCM lvra, *plvra;
c014a02e 177 long *vinds;
0f2d19dd 178 int k, kmax;
10b9343f
LC
179 int (*cproc) ();
180
181 cproc = cproc_ptr;
0f2d19dd
JB
182 switch (scm_ra_matchp (ra0, lra))
183 {
184 default:
185 case 0:
9cf5d9b7 186 scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
0f2d19dd
JB
187 case 2:
188 case 3:
189 case 4: /* Try unrolling arrays */
04b87de5 190 kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
0f2d19dd
JB
191 if (kmax < 0)
192 goto gencase;
193 vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
ff467021 194 if (SCM_IMP (vra0)) goto gencase;
04b87de5 195 if (!SCM_I_ARRAYP (vra0))
0f2d19dd 196 {
399aba0a 197 size_t length = scm_c_generalized_vector_length (vra0);
66b9d7d3 198 vra1 = scm_i_make_array (1);
04b87de5
MV
199 SCM_I_ARRAY_BASE (vra1) = 0;
200 SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
201 SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
202 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
203 SCM_I_ARRAY_V (vra1) = vra0;
0f2d19dd
JB
204 vra0 = vra1;
205 }
206 lvra = SCM_EOL;
207 plvra = &lvra;
208 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
209 {
210 ra1 = SCM_CAR (z);
66b9d7d3 211 vra1 = scm_i_make_array (1);
04b87de5
MV
212 SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
213 SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
214 if (!SCM_I_ARRAYP (ra1))
0f2d19dd 215 {
04b87de5
MV
216 SCM_I_ARRAY_BASE (vra1) = 0;
217 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
218 SCM_I_ARRAY_V (vra1) = ra1;
0f2d19dd 219 }
04b87de5 220 else if (!SCM_I_ARRAY_CONTP (ra1))
0f2d19dd
JB
221 goto gencase;
222 else
223 {
04b87de5
MV
224 SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
225 SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
226 SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
0f2d19dd
JB
227 }
228 *plvra = scm_cons (vra1, SCM_EOL);
25d8012c 229 plvra = SCM_CDRLOC (*plvra);
0f2d19dd
JB
230 }
231 return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
232 case 1:
233 gencase: /* Have to loop over all dimensions. */
66b9d7d3 234 vra0 = scm_i_make_array (1);
04b87de5 235 if (SCM_I_ARRAYP (ra0))
c209c88e 236 {
04b87de5 237 kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
c209c88e 238 if (kmax < 0)
0f2d19dd 239 {
04b87de5
MV
240 SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
241 SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
242 SCM_I_ARRAY_DIMS (vra0)->inc = 1;
0f2d19dd 243 }
c209c88e
GB
244 else
245 {
04b87de5
MV
246 SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
247 SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
248 SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
c209c88e 249 }
04b87de5
MV
250 SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
251 SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
c209c88e
GB
252 }
253 else
254 {
ee67e2fa 255 size_t length = scm_c_generalized_vector_length (ra0);
c209c88e 256 kmax = 0;
04b87de5
MV
257 SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
258 SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
259 SCM_I_ARRAY_DIMS (vra0)->inc = 1;
260 SCM_I_ARRAY_BASE (vra0) = 0;
261 SCM_I_ARRAY_V (vra0) = ra0;
c209c88e
GB
262 ra0 = vra0;
263 }
264 lvra = SCM_EOL;
265 plvra = &lvra;
266 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
267 {
268 ra1 = SCM_CAR (z);
66b9d7d3 269 vra1 = scm_i_make_array (1);
04b87de5
MV
270 SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
271 SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
272 if (SCM_I_ARRAYP (ra1))
c209c88e
GB
273 {
274 if (kmax >= 0)
04b87de5
MV
275 SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
276 SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
c209c88e
GB
277 }
278 else
279 {
04b87de5
MV
280 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
281 SCM_I_ARRAY_V (vra1) = ra1;
c209c88e
GB
282 }
283 *plvra = scm_cons (vra1, SCM_EOL);
284 plvra = SCM_CDRLOC (*plvra);
285 }
b4b33636 286
d66b74dc
LC
287 vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
288 indices_gc_hint);
b4b33636 289
c209c88e 290 for (k = 0; k <= kmax; k++)
04b87de5 291 vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
c209c88e
GB
292 k = kmax;
293 do
294 {
295 if (k == kmax)
296 {
297 SCM y = lra;
04b87de5 298 SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
c209c88e 299 for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
04b87de5 300 SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
c209c88e
GB
301 if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
302 return 0;
303 k--;
304 continue;
305 }
04b87de5 306 if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
c209c88e
GB
307 {
308 vinds[k]++;
309 k++;
310 continue;
311 }
04b87de5 312 vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
c209c88e
GB
313 k--;
314 }
315 while (k >= 0);
b4b33636 316
c209c88e 317 return 1;
0f2d19dd
JB
318 }
319}
320
321
3b3b36dd 322SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
c209c88e 323 (SCM ra, SCM fill),
b7e64f8b
BT
324 "Store @var{fill} in every element of array @var{ra}. The value\n"
325 "returned is unspecified.")
1bbd0b84 326#define FUNC_NAME s_scm_array_fill_x
ad310508 327{
c209c88e 328 scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
ad310508
MD
329 return SCM_UNSPECIFIED;
330}
1bbd0b84 331#undef FUNC_NAME
ad310508 332
5c11cc9d
GH
333/* to be used as cproc in scm_ramapc to fill an array dimension with
334 "fill". */
0f2d19dd 335int
e81d98ec 336scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
1bbd0b84 337#define FUNC_NAME s_scm_array_fill_x
0f2d19dd 338{
c014a02e 339 unsigned long i;
04b87de5
MV
340 unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
341 long inc = SCM_I_ARRAY_DIMS (ra)->inc;
342 unsigned long base = SCM_I_ARRAY_BASE (ra);
5c11cc9d 343
04b87de5 344 ra = SCM_I_ARRAY_V (ra);
b4bdadde 345
afaf9d0b 346 for (i = base; n--; i += inc)
85516012 347 GVSET (ra, i, fill);
afaf9d0b 348
0f2d19dd
JB
349 return 1;
350}
1bbd0b84 351#undef FUNC_NAME
0f2d19dd 352
0f2d19dd 353
72e2b592 354static int
1bbd0b84 355racp (SCM src, SCM dst)
0f2d19dd 356{
04b87de5 357 long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
72e2b592
DL
358 scm_t_array_handle h_s, h_d;
359 size_t i_s, i_d;
360 ssize_t inc_s, inc_d;
361
0f2d19dd 362 dst = SCM_CAR (dst);
72e2b592
DL
363 scm_generalized_vector_get_handle (SCM_I_ARRAY_V (src), &h_s);
364 scm_generalized_vector_get_handle (SCM_I_ARRAY_V (dst), &h_d);
365
366 i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
367 i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
368 inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
369 inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
c209c88e 370
399aba0a 371 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
72e2b592
DL
372 h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
373
374 scm_array_handle_release (&h_d);
375 scm_array_handle_release (&h_s);
376
0f2d19dd
JB
377 return 1;
378}
379
1bbd0b84 380SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
1cc91f1b 381
1bbd0b84 382
3b3b36dd 383SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
c209c88e 384 (SCM src, SCM dst),
8f85c0c6 385 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
b7e64f8b
BT
386 "Copy every element from vector or array @var{src} to the\n"
387 "corresponding element of @var{dst}. @var{dst} must have the\n"
388 "same rank as @var{src}, and be at least as large in each\n"
b380b885 389 "dimension. The order is unspecified.")
1bbd0b84 390#define FUNC_NAME s_scm_array_copy_x
0f2d19dd 391{
c209c88e 392 scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
0f2d19dd
JB
393 return SCM_UNSPECIFIED;
394}
1bbd0b84 395#undef FUNC_NAME
0f2d19dd
JB
396
397/* Functions callable by ARRAY-MAP! */
398
75a1b26c 399#if SCM_ENABLE_DEPRECATED == 1
1cc91f1b 400
0f2d19dd 401int
1bbd0b84 402scm_ra_eqp (SCM ra0, SCM ras)
0f2d19dd
JB
403{
404 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
fab07c30
MV
405 scm_t_array_handle ra0_handle;
406 scm_t_array_dim *ra0_dims;
407 size_t n;
408 ssize_t inc0;
409 size_t i0 = 0;
410 unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
04b87de5
MV
411 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
412 long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
04b87de5
MV
413 ra1 = SCM_I_ARRAY_V (ra1);
414 ra2 = SCM_I_ARRAY_V (ra2);
fab07c30
MV
415
416 scm_array_get_handle (ra0, &ra0_handle);
417 ra0_dims = scm_array_handle_dims (&ra0_handle);
418 n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
419 inc0 = ra0_dims[0].inc;
420
399aba0a 421 {
399aba0a 422 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
fab07c30 423 if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
85516012 424 if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
fab07c30 425 scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
399aba0a
MV
426 }
427
fab07c30 428 scm_array_handle_release (&ra0_handle);
0f2d19dd
JB
429 return 1;
430}
431
432/* opt 0 means <, nonzero means >= */
1cc91f1b 433
0f2d19dd 434static int
34d19ef6 435ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
0f2d19dd 436{
fab07c30
MV
437 scm_t_array_handle ra0_handle;
438 scm_t_array_dim *ra0_dims;
439 size_t n;
440 ssize_t inc0;
441 size_t i0 = 0;
442 unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
04b87de5
MV
443 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
444 long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
04b87de5
MV
445 ra1 = SCM_I_ARRAY_V (ra1);
446 ra2 = SCM_I_ARRAY_V (ra2);
399aba0a 447
fab07c30
MV
448 scm_array_get_handle (ra0, &ra0_handle);
449 ra0_dims = scm_array_handle_dims (&ra0_handle);
450 n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
451 inc0 = ra0_dims[0].inc;
452
399aba0a 453 {
399aba0a 454 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
fab07c30 455 if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
399aba0a 456 if (opt ?
85516012
MV
457 scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
458 scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
fab07c30 459 scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
399aba0a
MV
460 }
461
fab07c30 462 scm_array_handle_release (&ra0_handle);
0f2d19dd
JB
463 return 1;
464}
465
466
1cc91f1b 467
0f2d19dd 468int
1bbd0b84 469scm_ra_lessp (SCM ra0, SCM ras)
0f2d19dd
JB
470{
471 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
472}
473
1cc91f1b 474
0f2d19dd 475int
1bbd0b84 476scm_ra_leqp (SCM ra0, SCM ras)
0f2d19dd
JB
477{
478 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
479}
480
1cc91f1b 481
0f2d19dd 482int
1bbd0b84 483scm_ra_grp (SCM ra0, SCM ras)
0f2d19dd
JB
484{
485 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
486}
487
1cc91f1b 488
0f2d19dd 489int
1bbd0b84 490scm_ra_greqp (SCM ra0, SCM ras)
0f2d19dd
JB
491{
492 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
493}
494
495
0f2d19dd 496int
1bbd0b84 497scm_ra_sum (SCM ra0, SCM ras)
0f2d19dd 498{
04b87de5
MV
499 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
500 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
501 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
502 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 503 if (!scm_is_null(ras))
c209c88e
GB
504 {
505 SCM ra1 = SCM_CAR (ras);
04b87de5
MV
506 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
507 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
508 ra1 = SCM_I_ARRAY_V (ra1);
c209c88e
GB
509 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
510 {
511 default:
0f2d19dd 512 {
c209c88e 513 for (; n-- > 0; i0 += inc0, i1 += inc1)
85516012 514 GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
c209c88e
GB
515 break;
516 }
c209c88e
GB
517 }
518 }
0f2d19dd
JB
519 return 1;
520}
521
522
1cc91f1b 523
0f2d19dd 524int
1bbd0b84 525scm_ra_difference (SCM ra0, SCM ras)
0f2d19dd 526{
04b87de5
MV
527 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
528 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
529 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
530 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 531 if (scm_is_null (ras))
c209c88e
GB
532 {
533 switch (SCM_TYP7 (ra0))
534 {
535 default:
536 {
c209c88e 537 for (; n-- > 0; i0 += inc0)
85516012 538 GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
c209c88e
GB
539 break;
540 }
c209c88e
GB
541 }
542 }
0f2d19dd
JB
543 else
544 {
545 SCM ra1 = SCM_CAR (ras);
04b87de5
MV
546 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
547 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
548 ra1 = SCM_I_ARRAY_V (ra1);
0f2d19dd
JB
549 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
550 {
551 default:
552 {
0f2d19dd 553 for (; n-- > 0; i0 += inc0, i1 += inc1)
85516012
MV
554 GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
555 GVREF (ra1, i1)));
0f2d19dd
JB
556 break;
557 }
0f2d19dd
JB
558 }
559 }
560 return 1;
561}
562
563
1cc91f1b 564
0f2d19dd 565int
1bbd0b84 566scm_ra_product (SCM ra0, SCM ras)
0f2d19dd 567{
04b87de5
MV
568 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
569 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
570 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
571 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 572 if (!scm_is_null (ras))
c209c88e
GB
573 {
574 SCM ra1 = SCM_CAR (ras);
04b87de5
MV
575 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
576 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
577 ra1 = SCM_I_ARRAY_V (ra1);
c209c88e
GB
578 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
579 {
580 default:
0f2d19dd 581 {
c209c88e 582 for (; n-- > 0; i0 += inc0, i1 += inc1)
85516012
MV
583 GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
584 GVREF (ra1, i1)));
c209c88e 585 }
c209c88e
GB
586 }
587 }
0f2d19dd
JB
588 return 1;
589}
590
1cc91f1b 591
0f2d19dd 592int
1bbd0b84 593scm_ra_divide (SCM ra0, SCM ras)
0f2d19dd 594{
04b87de5
MV
595 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
596 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
597 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
598 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 599 if (scm_is_null (ras))
c209c88e
GB
600 {
601 switch (SCM_TYP7 (ra0))
602 {
603 default:
604 {
c209c88e 605 for (; n-- > 0; i0 += inc0)
85516012 606 GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
c209c88e
GB
607 break;
608 }
c209c88e
GB
609 }
610 }
0f2d19dd
JB
611 else
612 {
613 SCM ra1 = SCM_CAR (ras);
04b87de5
MV
614 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
615 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
616 ra1 = SCM_I_ARRAY_V (ra1);
0f2d19dd
JB
617 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
618 {
619 default:
620 {
0f2d19dd 621 for (; n-- > 0; i0 += inc0, i1 += inc1)
afaf9d0b 622 {
85516012
MV
623 SCM res = scm_divide (GVREF (ra0, i0),
624 GVREF (ra1, i1));
625 GVSET (ra0, i0, res);
afaf9d0b 626 }
0f2d19dd
JB
627 break;
628 }
0f2d19dd
JB
629 }
630 }
631 return 1;
632}
633
1cc91f1b 634
0f2d19dd 635int
1bbd0b84 636scm_array_identity (SCM dst, SCM src)
0f2d19dd
JB
637{
638 return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
639}
640
75a1b26c 641#endif /* SCM_ENABLE_DEPRECATED */
0f2d19dd 642
75a1b26c 643static int
34d19ef6 644ramap (SCM ra0, SCM proc, SCM ras)
0f2d19dd 645{
04b87de5
MV
646 long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
647 long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
648 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
649 long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
650 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 651 if (scm_is_null (ras))
c209c88e 652 for (; i <= n; i++)
85516012 653 GVSET (ra0, i*inc+base, scm_call_0 (proc));
0f2d19dd
JB
654 else
655 {
656 SCM ra1 = SCM_CAR (ras);
34d19ef6 657 SCM args;
04b87de5
MV
658 unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
659 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
660 ra1 = SCM_I_ARRAY_V (ra1);
e7efe8e7 661 ras = scm_vector (SCM_CDR (ras));
34d19ef6 662
0f2d19dd
JB
663 for (; i <= n; i++, i1 += inc1)
664 {
665 args = SCM_EOL;
ee67e2fa 666 for (k = scm_c_vector_length (ras); k--;)
85516012
MV
667 args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
668 args = scm_cons (GVREF (ra1, i1), args);
669 GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
0f2d19dd
JB
670 }
671 }
672 return 1;
673}
674
1cc91f1b 675
1bbd0b84 676SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
1cc91f1b 677
718866aa 678SCM_SYMBOL (sym_b, "b");
1bbd0b84 679
3b3b36dd 680SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
c209c88e 681 (SCM ra0, SCM proc, SCM lra),
8f85c0c6 682 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
b7e64f8b
BT
683 "@var{array1}, @dots{} must have the same number of dimensions\n"
684 "as @var{ra0} and have a range for each index which includes the\n"
685 "range for the corresponding index in @var{ra0}. @var{proc} is\n"
686 "applied to each tuple of elements of @var{array1}, @dots{} and\n"
687 "the result is stored as the corresponding element in @var{ra0}.\n"
688 "The value returned is unspecified. The order of application is\n"
689 "unspecified.")
1bbd0b84 690#define FUNC_NAME s_scm_array_map_x
0f2d19dd 691{
34d19ef6 692 SCM_VALIDATE_PROC (2, proc);
af45e3b0 693 SCM_VALIDATE_REST_ARGUMENT (lra);
f530e94f 694
31d845b4
AW
695 scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
696 return SCM_UNSPECIFIED;
0f2d19dd 697}
1bbd0b84 698#undef FUNC_NAME
0f2d19dd 699
1cc91f1b 700
0f2d19dd 701static int
34d19ef6 702rafe (SCM ra0, SCM proc, SCM ras)
0f2d19dd 703{
04b87de5
MV
704 long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
705 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
706 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
707 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
708 ra0 = SCM_I_ARRAY_V (ra0);
d2e53ed6 709 if (scm_is_null (ras))
c209c88e 710 for (; i <= n; i++, i0 += inc0)
85516012 711 scm_call_1 (proc, GVREF (ra0, i0));
0f2d19dd
JB
712 else
713 {
714 SCM ra1 = SCM_CAR (ras);
34d19ef6 715 SCM args;
04b87de5
MV
716 unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
717 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
718 ra1 = SCM_I_ARRAY_V (ra1);
e7efe8e7
AW
719 ras = scm_vector (SCM_CDR (ras));
720
0f2d19dd
JB
721 for (; i <= n; i++, i0 += inc0, i1 += inc1)
722 {
723 args = SCM_EOL;
ee67e2fa 724 for (k = scm_c_vector_length (ras); k--;)
85516012
MV
725 args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
726 args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
fdc28395 727 scm_apply_0 (proc, args);
0f2d19dd
JB
728 }
729 }
730 return 1;
731}
732
733
3b3b36dd 734SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
c209c88e 735 (SCM proc, SCM ra0, SCM lra),
b7e64f8b 736 "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
b380b885 737 "in row-major order. The value returned is unspecified.")
1bbd0b84 738#define FUNC_NAME s_scm_array_for_each
0f2d19dd 739{
34d19ef6 740 SCM_VALIDATE_PROC (1, proc);
af45e3b0 741 SCM_VALIDATE_REST_ARGUMENT (lra);
c209c88e 742 scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
0f2d19dd
JB
743 return SCM_UNSPECIFIED;
744}
1bbd0b84 745#undef FUNC_NAME
0f2d19dd 746
3b3b36dd 747SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
c209c88e 748 (SCM ra, SCM proc),
b7e64f8b 749 "Apply @var{proc} to the indices of each element of @var{ra} in\n"
b380b885
MD
750 "turn, storing the result in the corresponding element. The value\n"
751 "returned and the order of application are unspecified.\n\n"
752 "One can implement @var{array-indexes} as\n"
1e6808ea 753 "@lisp\n"
b380b885
MD
754 "(define (array-indexes array)\n"
755 " (let ((ra (apply make-array #f (array-shape array))))\n"
756 " (array-index-map! ra (lambda x x))\n"
757 " ra))\n"
1e6808ea 758 "@end lisp\n"
b380b885 759 "Another example:\n"
1e6808ea 760 "@lisp\n"
b380b885
MD
761 "(define (apl:index-generator n)\n"
762 " (let ((v (make-uniform-vector n 1)))\n"
763 " (array-index-map! v (lambda (i) i))\n"
764 " v))\n"
1e6808ea 765 "@end lisp")
1bbd0b84 766#define FUNC_NAME s_scm_array_index_map_x
0f2d19dd 767{
c014a02e 768 unsigned long i;
34d19ef6 769 SCM_VALIDATE_PROC (2, proc);
399aba0a 770
5ead53fc 771 if (SCM_I_ARRAYP (ra))
399aba0a
MV
772 {
773 SCM args = SCM_EOL;
04b87de5 774 int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
b4b33636
MV
775 long *vinds;
776
399aba0a
MV
777 if (kmax < 0)
778 return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
b4b33636 779
d66b74dc
LC
780 vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
781 indices_gc_hint);
b4b33636 782
399aba0a 783 for (k = 0; k <= kmax; k++)
04b87de5 784 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
399aba0a
MV
785 k = kmax;
786 do
787 {
788 if (k == kmax)
789 {
04b87de5 790 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
b4b33636 791 i = cind (ra, vinds);
04b87de5 792 for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
399aba0a
MV
793 {
794 for (j = kmax + 1, args = SCM_EOL; j--;)
795 args = scm_cons (scm_from_long (vinds[j]), args);
04b87de5
MV
796 GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
797 i += SCM_I_ARRAY_DIMS (ra)[k].inc;
399aba0a
MV
798 }
799 k--;
800 continue;
801 }
04b87de5 802 if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
399aba0a
MV
803 {
804 vinds[k]++;
805 k++;
806 continue;
807 }
04b87de5 808 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
399aba0a
MV
809 k--;
810 }
811 while (k >= 0);
b4b33636 812
399aba0a 813 return SCM_UNSPECIFIED;
e42c09cc 814 }
5ead53fc
MV
815 else if (scm_is_generalized_vector (ra))
816 {
817 size_t length = scm_c_generalized_vector_length (ra);
818 for (i = 0; i < length; i++)
819 GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
820 return SCM_UNSPECIFIED;
821 }
822 else
399aba0a 823 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
0f2d19dd 824}
1bbd0b84 825#undef FUNC_NAME
0f2d19dd 826
1cc91f1b 827
0f2d19dd 828static int
a587d6a9
AW
829array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
830 size_t dim, unsigned long posx, unsigned long posy)
0f2d19dd 831{
a587d6a9
AW
832 if (dim == scm_array_handle_rank (hx))
833 return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
834 scm_array_handle_ref (hy, posy)));
e466c6a2 835 else
c209c88e 836 {
a587d6a9
AW
837 long incx, incy;
838 size_t i;
399aba0a 839
a587d6a9
AW
840 if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
841 || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
842 return 0;
843
844 i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
845
846 incx = hx->dims[dim].inc;
847 incy = hy->dims[dim].inc;
848 posx += (i - 1) * incx;
849 posy += (i - 1) * incy;
850
851 for (; i > 0; i--, posx -= incx, posy -= incy)
852 if (!array_compare (hx, hy, dim + 1, posx, posy))
853 return 0;
c209c88e 854 return 1;
c209c88e 855 }
0f2d19dd
JB
856}
857
a587d6a9
AW
858SCM
859scm_array_equal_p (SCM x, SCM y)
0f2d19dd 860{
a587d6a9
AW
861 scm_t_array_handle hx, hy;
862 SCM res;
863
864 scm_array_get_handle (x, &hx);
865 scm_array_get_handle (y, &hy);
866
867 res = scm_from_bool (hx.ndims == hy.ndims
868 && hx.element_type == hy.element_type);
3ffd1ba9 869
a587d6a9
AW
870 if (scm_is_true (res))
871 res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
0f2d19dd 872
a587d6a9
AW
873 scm_array_handle_release (&hy);
874 scm_array_handle_release (&hx);
1cc91f1b 875
a587d6a9 876 return res;
0f2d19dd
JB
877}
878
f1d19308 879static SCM scm_i_array_equal_p (SCM, SCM, SCM);
31d845b4
AW
880SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
881 (SCM ra0, SCM ra1, SCM rest),
1e6808ea
MG
882 "Return @code{#t} iff all arguments are arrays with the same\n"
883 "shape, the same type, and have corresponding elements which are\n"
884 "either @code{equal?} or @code{array-equal?}. This function\n"
a587d6a9 885 "differs from @code{equal?} in that all arguments must be arrays.")
31d845b4
AW
886#define FUNC_NAME s_scm_i_array_equal_p
887{
888 if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
889 return SCM_BOOL_T;
890
891 while (!scm_is_null (rest))
8a1f4f98 892 { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
31d845b4 893 return SCM_BOOL_F;
8a1f4f98
AW
894 ra0 = ra1;
895 ra1 = scm_car (rest);
31d845b4
AW
896 rest = scm_cdr (rest);
897 }
898 return scm_array_equal_p (ra0, ra1);
0f981281 899}
4079f87e 900#undef FUNC_NAME
0f2d19dd 901
1cc91f1b 902
0f2d19dd 903void
5d1b3b2d 904scm_init_array_map (void)
0f2d19dd 905{
5d1b3b2d 906#include "libguile/array-map.x"
1bbd0b84 907 scm_add_feature (s_scm_array_for_each);
0f2d19dd 908}
89e00824
ML
909
910/*
911 Local Variables:
912 c-file-style: "gnu"
913 End:
914*/