1 /* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19 /*
20 HWN:FIXME::
21 Someone should rename this to arraymap.c; that would reflect the
22 contents better. */
23
24
25
26
27 #ifdef HAVE_CONFIG_H
28 # include <config.h>
29 #endif
30
31 #include "libguile/_scm.h"
32 #include "libguile/strings.h"
33 #include "libguile/unif.h"
34 #include "libguile/smob.h"
35 #include "libguile/chars.h"
36 #include "libguile/eq.h"
37 #include "libguile/eval.h"
38 #include "libguile/feature.h"
39 #include "libguile/root.h"
40 #include "libguile/vectors.h"
41 #include "libguile/srfi-4.h"
42 #include "libguile/dynwind.h"
43
44 #include "libguile/validate.h"
45 #include "libguile/ramap.h"
46
47
48 typedef struct
49 {
50 char *name;
51 SCM sproc;
52 int (*vproc) ();
53 } ra_iproc;
54
55
56 /* These tables are a kluge that will not scale well when more
57 * vectorized subrs are added. It is tempting to steal some bits from
58 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
59 * offset into a table of vectorized subrs.
60 */
61
62 static ra_iproc ra_rpsubrs[] =
63 {
64 {"=", SCM_UNDEFINED, scm_ra_eqp},
65 {"<", SCM_UNDEFINED, scm_ra_lessp},
66 {"<=", SCM_UNDEFINED, scm_ra_leqp},
67 {">", SCM_UNDEFINED, scm_ra_grp},
68 {">=", SCM_UNDEFINED, scm_ra_greqp},
69 {0, 0, 0}
70 };
71
72 static ra_iproc ra_asubrs[] =
73 {
74 {"+", SCM_UNDEFINED, scm_ra_sum},
75 {"-", SCM_UNDEFINED, scm_ra_difference},
76 {"*", SCM_UNDEFINED, scm_ra_product},
77 {"/", SCM_UNDEFINED, scm_ra_divide},
78 {0, 0, 0}
79 };
80
81
82 #define GVREF scm_c_generalized_vector_ref
83 #define GVSET scm_c_generalized_vector_set_x
84
85 static unsigned long
cind(SCM ra,long * ve)86 cind (SCM ra, long *ve)
87 {
88 unsigned long i;
89 int k;
90 if (!SCM_I_ARRAYP (ra))
91 return *ve;
92 i = SCM_I_ARRAY_BASE (ra);
93 for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
94 i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
95 return i;
96 }
97
98
99 /* Checker for scm_array mapping functions:
100 return values: 4 --> shapes, increments, and bases are the same;
101 3 --> shapes and increments are the same;
102 2 --> shapes are the same;
103 1 --> ras are at least as big as ra0;
104 0 --> no match.
105 */
106
107 int
scm_ra_matchp(SCM ra0,SCM ras)108 scm_ra_matchp (SCM ra0, SCM ras)
109 {
110 SCM ra1;
111 scm_t_array_dim dims;
112 scm_t_array_dim *s0 = &dims;
113 scm_t_array_dim *s1;
114 unsigned long bas0 = 0;
115 int i, ndim = 1;
116 int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
117
118 if (scm_is_generalized_vector (ra0))
119 {
120 s0->lbnd = 0;
121 s0->inc = 1;
122 s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
123 }
124 else if (SCM_I_ARRAYP (ra0))
125 {
126 ndim = SCM_I_ARRAY_NDIM (ra0);
127 s0 = SCM_I_ARRAY_DIMS (ra0);
128 bas0 = SCM_I_ARRAY_BASE (ra0);
129 }
130 else
131 return 0;
132
133 while (SCM_NIMP (ras))
134 {
135 ra1 = SCM_CAR (ras);
136
137 if (scm_is_generalized_vector (ra1))
138 {
139 size_t length;
140
141 if (1 != ndim)
142 return 0;
143
144 length = scm_c_generalized_vector_length (ra1);
145
146 switch (exact)
147 {
148 case 4:
149 if (0 != bas0)
150 exact = 3;
151 case 3:
152 if (1 != s0->inc)
153 exact = 2;
154 case 2:
155 if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
156 break;
157 exact = 1;
158 case 1:
159 if (s0->lbnd < 0 || s0->ubnd >= length)
160 return 0;
161 }
162 }
163 else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
164 {
165 s1 = SCM_I_ARRAY_DIMS (ra1);
166 if (bas0 != SCM_I_ARRAY_BASE (ra1))
167 exact = 3;
168 for (i = 0; i < ndim; i++)
169 switch (exact)
170 {
171 case 4:
172 case 3:
173 if (s0[i].inc != s1[i].inc)
174 exact = 2;
175 case 2:
176 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
177 break;
178 exact = 1;
179 default:
180 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
181 return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
182 }
183 }
184 else
185 return 0;
186
187 ras = SCM_CDR (ras);
188 }
189
190 return exact;
191 }
192
193 /* array mapper: apply cproc to each dimension of the given arrays?.
194 int (*cproc) (); procedure to call on unrolled arrays?
195 cproc (dest, source list) or
196 cproc (dest, data, source list).
197 SCM data; data to give to cproc or unbound.
198 SCM ra0; destination array.
199 SCM lra; list of source arrays.
200 const char *what; caller, for error reporting. */
201 int
scm_ramapc(int (* cproc)(),SCM data,SCM ra0,SCM lra,const char * what)202 scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
203 {
204 SCM z;
205 SCM vra0, ra1, vra1;
206 SCM lvra, *plvra;
207 long *vinds;
208 int k, kmax;
209 switch (scm_ra_matchp (ra0, lra))
210 {
211 default:
212 case 0:
213 scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
214 case 2:
215 case 3:
216 case 4: /* Try unrolling arrays */
217 kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
218 if (kmax < 0)
219 goto gencase;
220 vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
221 if (SCM_IMP (vra0)) goto gencase;
222 if (!SCM_I_ARRAYP (vra0))
223 {
224 size_t length = scm_c_generalized_vector_length (vra0);
225 vra1 = scm_i_make_ra (1, 0);
226 SCM_I_ARRAY_BASE (vra1) = 0;
227 SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
228 SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
229 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
230 SCM_I_ARRAY_V (vra1) = vra0;
231 vra0 = vra1;
232 }
233 lvra = SCM_EOL;
234 plvra = &lvra;
235 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
236 {
237 ra1 = SCM_CAR (z);
238 vra1 = scm_i_make_ra (1, 0);
239 SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
240 SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
241 if (!SCM_I_ARRAYP (ra1))
242 {
243 SCM_I_ARRAY_BASE (vra1) = 0;
244 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
245 SCM_I_ARRAY_V (vra1) = ra1;
246 }
247 else if (!SCM_I_ARRAY_CONTP (ra1))
248 goto gencase;
249 else
250 {
251 SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
252 SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
253 SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
254 }
255 *plvra = scm_cons (vra1, SCM_EOL);
256 plvra = SCM_CDRLOC (*plvra);
257 }
258 return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
259 case 1:
260 gencase: /* Have to loop over all dimensions. */
261 vra0 = scm_i_make_ra (1, 0);
262 if (SCM_I_ARRAYP (ra0))
263 {
264 kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
265 if (kmax < 0)
266 {
267 SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
268 SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
269 SCM_I_ARRAY_DIMS (vra0)->inc = 1;
270 }
271 else
272 {
273 SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
274 SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
275 SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
276 }
277 SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
278 SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
279 }
280 else
281 {
282 size_t length = scm_c_generalized_vector_length (ra0);
283 kmax = 0;
284 SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
285 SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
286 SCM_I_ARRAY_DIMS (vra0)->inc = 1;
287 SCM_I_ARRAY_BASE (vra0) = 0;
288 SCM_I_ARRAY_V (vra0) = ra0;
289 ra0 = vra0;
290 }
291 lvra = SCM_EOL;
292 plvra = &lvra;
293 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
294 {
295 ra1 = SCM_CAR (z);
296 vra1 = scm_i_make_ra (1, 0);
297 SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
298 SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
299 if (SCM_I_ARRAYP (ra1))
300 {
301 if (kmax >= 0)
302 SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
303 SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
304 }
305 else
306 {
307 SCM_I_ARRAY_DIMS (vra1)->inc = 1;
308 SCM_I_ARRAY_V (vra1) = ra1;
309 }
310 *plvra = scm_cons (vra1, SCM_EOL);
311 plvra = SCM_CDRLOC (*plvra);
312 }
313
314 scm_dynwind_begin (0);
315
316 vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
317 scm_dynwind_free (vinds);
318
319 for (k = 0; k <= kmax; k++)
320 vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
321 k = kmax;
322 do
323 {
324 if (k == kmax)
325 {
326 SCM y = lra;
327 SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
328 for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
329 SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
330 if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
331 return 0;
332 k--;
333 continue;
334 }
335 if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
336 {
337 vinds[k]++;
338 k++;
339 continue;
340 }
341 vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
342 k--;
343 }
344 while (k >= 0);
345
346 scm_dynwind_end ();
347 return 1;
348 }
349 }
350
351
352 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
353 (SCM ra, SCM fill),
354 "Store @var{fill} in every element of @var{array}. The value returned\n"
355 "is unspecified.")
356 #define FUNC_NAME s_scm_array_fill_x
357 {
358 scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
359 return SCM_UNSPECIFIED;
360 }
361 #undef FUNC_NAME
362
363 /* to be used as cproc in scm_ramapc to fill an array dimension with
364 "fill". */
365 int
scm_array_fill_int(SCM ra,SCM fill,SCM ignore SCM_UNUSED)366 scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
367 #define FUNC_NAME s_scm_array_fill_x
368 {
369 unsigned long i;
370 unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
371 long inc = SCM_I_ARRAY_DIMS (ra)->inc;
372 unsigned long base = SCM_I_ARRAY_BASE (ra);
373
374 ra = SCM_I_ARRAY_V (ra);
375
376 for (i = base; n--; i += inc)
377 GVSET (ra, i, fill);
378
379 return 1;
380 }
381 #undef FUNC_NAME
382
383
384
385 static int
racp(SCM src,SCM dst)386 racp (SCM src, SCM dst)
387 {
388 long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
389 long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
390 unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
391 dst = SCM_CAR (dst);
392 inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
393 i_d = SCM_I_ARRAY_BASE (dst);
394 src = SCM_I_ARRAY_V (src);
395 dst = SCM_I_ARRAY_V (dst);
396
397 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
398 GVSET (dst, i_d, GVREF (src, i_s));
399 return 1;
400 }
401
402 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
403
404
405 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
406 (SCM src, SCM dst),
407 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
408 "Copy every element from vector or array @var{source} to the\n"
409 "corresponding element of @var{destination}. @var{destination} must have\n"
410 "the same rank as @var{source}, and be at least as large in each\n"
411 "dimension. The order is unspecified.")
412 #define FUNC_NAME s_scm_array_copy_x
413 {
414 scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
415 return SCM_UNSPECIFIED;
416 }
417 #undef FUNC_NAME
418
419 /* Functions callable by ARRAY-MAP! */
420
421
422 int
scm_ra_eqp(SCM ra0,SCM ras)423 scm_ra_eqp (SCM ra0, SCM ras)
424 {
425 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
426 scm_t_array_handle ra0_handle;
427 scm_t_array_dim *ra0_dims;
428 size_t n;
429 ssize_t inc0;
430 size_t i0 = 0;
431 unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
432 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
433 long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
434 ra1 = SCM_I_ARRAY_V (ra1);
435 ra2 = SCM_I_ARRAY_V (ra2);
436
437 scm_array_get_handle (ra0, &ra0_handle);
438 ra0_dims = scm_array_handle_dims (&ra0_handle);
439 n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
440 inc0 = ra0_dims[0].inc;
441
442 {
443 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
444 if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
445 if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
446 scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
447 }
448
449 scm_array_handle_release (&ra0_handle);
450 return 1;
451 }
452
453 /* opt 0 means <, nonzero means >= */
454
455 static int
ra_compare(SCM ra0,SCM ra1,SCM ra2,int opt)456 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
457 {
458 scm_t_array_handle ra0_handle;
459 scm_t_array_dim *ra0_dims;
460 size_t n;
461 ssize_t inc0;
462 size_t i0 = 0;
463 unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
464 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
465 long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
466 ra1 = SCM_I_ARRAY_V (ra1);
467 ra2 = SCM_I_ARRAY_V (ra2);
468
469 scm_array_get_handle (ra0, &ra0_handle);
470 ra0_dims = scm_array_handle_dims (&ra0_handle);
471 n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
472 inc0 = ra0_dims[0].inc;
473
474 {
475 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
476 if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
477 if (opt ?
478 scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
479 scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
480 scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
481 }
482
483 scm_array_handle_release (&ra0_handle);
484 return 1;
485 }
486
487
488
489 int
scm_ra_lessp(SCM ra0,SCM ras)490 scm_ra_lessp (SCM ra0, SCM ras)
491 {
492 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
493 }
494
495
496 int
scm_ra_leqp(SCM ra0,SCM ras)497 scm_ra_leqp (SCM ra0, SCM ras)
498 {
499 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
500 }
501
502
503 int
scm_ra_grp(SCM ra0,SCM ras)504 scm_ra_grp (SCM ra0, SCM ras)
505 {
506 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
507 }
508
509
510 int
scm_ra_greqp(SCM ra0,SCM ras)511 scm_ra_greqp (SCM ra0, SCM ras)
512 {
513 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
514 }
515
516
517 int
scm_ra_sum(SCM ra0,SCM ras)518 scm_ra_sum (SCM ra0, SCM ras)
519 {
520 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
521 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
522 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
523 ra0 = SCM_I_ARRAY_V (ra0);
524 if (!scm_is_null(ras))
525 {
526 SCM ra1 = SCM_CAR (ras);
527 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
528 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
529 ra1 = SCM_I_ARRAY_V (ra1);
530 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
531 {
532 default:
533 {
534 for (; n-- > 0; i0 += inc0, i1 += inc1)
535 GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
536 break;
537 }
538 }
539 }
540 return 1;
541 }
542
543
544
545 int
scm_ra_difference(SCM ra0,SCM ras)546 scm_ra_difference (SCM ra0, SCM ras)
547 {
548 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
549 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
550 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
551 ra0 = SCM_I_ARRAY_V (ra0);
552 if (scm_is_null (ras))
553 {
554 switch (SCM_TYP7 (ra0))
555 {
556 default:
557 {
558 for (; n-- > 0; i0 += inc0)
559 GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
560 break;
561 }
562 }
563 }
564 else
565 {
566 SCM ra1 = SCM_CAR (ras);
567 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
568 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
569 ra1 = SCM_I_ARRAY_V (ra1);
570 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
571 {
572 default:
573 {
574 for (; n-- > 0; i0 += inc0, i1 += inc1)
575 GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
576 GVREF (ra1, i1)));
577 break;
578 }
579 }
580 }
581 return 1;
582 }
583
584
585
586 int
scm_ra_product(SCM ra0,SCM ras)587 scm_ra_product (SCM ra0, SCM ras)
588 {
589 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
590 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
591 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
592 ra0 = SCM_I_ARRAY_V (ra0);
593 if (!scm_is_null (ras))
594 {
595 SCM ra1 = SCM_CAR (ras);
596 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
597 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
598 ra1 = SCM_I_ARRAY_V (ra1);
599 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
600 {
601 default:
602 {
603 for (; n-- > 0; i0 += inc0, i1 += inc1)
604 GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
605 GVREF (ra1, i1)));
606 }
607 }
608 }
609 return 1;
610 }
611
612
613 int
scm_ra_divide(SCM ra0,SCM ras)614 scm_ra_divide (SCM ra0, SCM ras)
615 {
616 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
617 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
618 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
619 ra0 = SCM_I_ARRAY_V (ra0);
620 if (scm_is_null (ras))
621 {
622 switch (SCM_TYP7 (ra0))
623 {
624 default:
625 {
626 for (; n-- > 0; i0 += inc0)
627 GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
628 break;
629 }
630 }
631 }
632 else
633 {
634 SCM ra1 = SCM_CAR (ras);
635 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
636 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
637 ra1 = SCM_I_ARRAY_V (ra1);
638 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
639 {
640 default:
641 {
642 for (; n-- > 0; i0 += inc0, i1 += inc1)
643 {
644 SCM res = scm_divide (GVREF (ra0, i0),
645 GVREF (ra1, i1));
646 GVSET (ra0, i0, res);
647 }
648 break;
649 }
650 }
651 }
652 return 1;
653 }
654
655
656 int
scm_array_identity(SCM dst,SCM src)657 scm_array_identity (SCM dst, SCM src)
658 {
659 return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
660 }
661
662
663
664 static int
ramap(SCM ra0,SCM proc,SCM ras)665 ramap (SCM ra0, SCM proc, SCM ras)
666 {
667 long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
668 long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
669 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
670 long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
671 ra0 = SCM_I_ARRAY_V (ra0);
672 if (scm_is_null (ras))
673 for (; i <= n; i++)
674 GVSET (ra0, i*inc+base, scm_call_0 (proc));
675 else
676 {
677 SCM ra1 = SCM_CAR (ras);
678 SCM args;
679 unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
680 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
681 ra1 = SCM_I_ARRAY_V (ra1);
682 ras = SCM_CDR (ras);
683 if (scm_is_null(ras))
684 ras = scm_nullvect;
685 else
686 ras = scm_vector (ras);
687
688 for (; i <= n; i++, i1 += inc1)
689 {
690 args = SCM_EOL;
691 for (k = scm_c_vector_length (ras); k--;)
692 args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
693 args = scm_cons (GVREF (ra1, i1), args);
694 GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
695 }
696 }
697 return 1;
698 }
699
700
701 static int
ramap_dsubr(SCM ra0,SCM proc,SCM ras)702 ramap_dsubr (SCM ra0, SCM proc, SCM ras)
703 {
704 SCM ra1 = SCM_CAR (ras);
705 unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
706 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
707 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
708 ra0 = SCM_I_ARRAY_V (ra0);
709 ra1 = SCM_I_ARRAY_V (ra1);
710 switch (SCM_TYP7 (ra0))
711 {
712 default:
713 for (; n-- > 0; i0 += inc0, i1 += inc1)
714 GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
715 break;
716 }
717 return 1;
718 }
719
720
721
722 static int
ramap_rp(SCM ra0,SCM proc,SCM ras)723 ramap_rp (SCM ra0, SCM proc, SCM ras)
724 {
725 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
726 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
727 unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
728 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
729 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
730 long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
731 ra0 = SCM_I_ARRAY_V (ra0);
732 ra1 = SCM_I_ARRAY_V (ra1);
733 ra2 = SCM_I_ARRAY_V (ra2);
734
735 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
736 if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
737 if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
738 scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
739
740 return 1;
741 }
742
743
744
745 static int
ramap_1(SCM ra0,SCM proc,SCM ras)746 ramap_1 (SCM ra0, SCM proc, SCM ras)
747 {
748 SCM ra1 = SCM_CAR (ras);
749 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
750 unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
751 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
752 ra0 = SCM_I_ARRAY_V (ra0);
753 ra1 = SCM_I_ARRAY_V (ra1);
754 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
755 for (; n-- > 0; i0 += inc0, i1 += inc1)
756 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
757 else
758 for (; n-- > 0; i0 += inc0, i1 += inc1)
759 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
760 return 1;
761 }
762
763
764
765 static int
ramap_2o(SCM ra0,SCM proc,SCM ras)766 ramap_2o (SCM ra0, SCM proc, SCM ras)
767 {
768 SCM ra1 = SCM_CAR (ras);
769 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
770 unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
771 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
772 ra0 = SCM_I_ARRAY_V (ra0);
773 ra1 = SCM_I_ARRAY_V (ra1);
774 ras = SCM_CDR (ras);
775 if (scm_is_null (ras))
776 {
777 for (; n-- > 0; i0 += inc0, i1 += inc1)
778 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
779 }
780 else
781 {
782 SCM ra2 = SCM_CAR (ras);
783 unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
784 long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
785 ra2 = SCM_I_ARRAY_V (ra2);
786 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
787 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
788 }
789 return 1;
790 }
791
792
793
794 static int
ramap_a(SCM ra0,SCM proc,SCM ras)795 ramap_a (SCM ra0, SCM proc, SCM ras)
796 {
797 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
798 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
799 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
800 ra0 = SCM_I_ARRAY_V (ra0);
801 if (scm_is_null (ras))
802 for (; n-- > 0; i0 += inc0)
803 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
804 else
805 {
806 SCM ra1 = SCM_CAR (ras);
807 unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
808 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
809 ra1 = SCM_I_ARRAY_V (ra1);
810 for (; n-- > 0; i0 += inc0, i1 += inc1)
811 GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
812 }
813 return 1;
814 }
815
816
817 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
818
819 SCM_SYMBOL (sym_b, "b");
820
821 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
822 (SCM ra0, SCM proc, SCM lra),
823 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
824 "@var{array1}, @dots{} must have the same number of dimensions as\n"
825 "@var{array0} and have a range for each index which includes the range\n"
826 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
827 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
828 "as the corresponding element in @var{array0}. The value returned is\n"
829 "unspecified. The order of application is unspecified.")
830 #define FUNC_NAME s_scm_array_map_x
831 {
832 SCM_VALIDATE_PROC (2, proc);
833 SCM_VALIDATE_REST_ARGUMENT (lra);
834
835 switch (SCM_TYP7 (proc))
836 {
837 default:
838 gencase:
839 scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
840 return SCM_UNSPECIFIED;
841 case scm_tc7_subr_1:
842 if (! scm_is_pair (lra))
843 SCM_WRONG_NUM_ARGS (); /* need 1 source */
844 scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
845 return SCM_UNSPECIFIED;
846 case scm_tc7_subr_2:
847 if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
848 SCM_WRONG_NUM_ARGS (); /* need 2 sources */
849 goto subr_2o;
850 case scm_tc7_subr_2o:
851 if (! scm_is_pair (lra))
852 SCM_WRONG_NUM_ARGS (); /* need 1 source */
853 subr_2o:
854 scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
855 return SCM_UNSPECIFIED;
856 case scm_tc7_dsubr:
857 if (! scm_is_pair (lra))
858 SCM_WRONG_NUM_ARGS (); /* need 1 source */
859 scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
860 return SCM_UNSPECIFIED;
861 case scm_tc7_rpsubr:
862 {
863 ra_iproc *p;
864 if (!scm_is_typed_array (ra0, sym_b))
865 goto gencase;
866 scm_array_fill_x (ra0, SCM_BOOL_T);
867 for (p = ra_rpsubrs; p->name; p++)
868 if (scm_is_eq (proc, p->sproc))
869 {
870 while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
871 {
872 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
873 lra = SCM_CDR (lra);
874 }
875 return SCM_UNSPECIFIED;
876 }
877 while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
878 {
879 scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
880 lra = SCM_CDR (lra);
881 }
882 return SCM_UNSPECIFIED;
883 }
884 case scm_tc7_asubr:
885 if (scm_is_null (lra))
886 {
887 SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
888 scm_array_fill_x (ra0, fill);
889 }
890 else
891 {
892 SCM tail, ra1 = SCM_CAR (lra);
893 SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
894 ra_iproc *p;
895 /* Check to see if order might matter.
896 This might be an argument for a separate
897 SERIAL-ARRAY-MAP! */
898 if (scm_is_eq (v0, ra1)
899 || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
900 if (!scm_is_eq (ra0, ra1)
901 || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
902 goto gencase;
903 for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
904 {
905 ra1 = SCM_CAR (tail);
906 if (scm_is_eq (v0, ra1)
907 || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
908 goto gencase;
909 }
910 for (p = ra_asubrs; p->name; p++)
911 if (scm_is_eq (proc, p->sproc))
912 {
913 if (!scm_is_eq (ra0, SCM_CAR (lra)))
914 scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
915 lra = SCM_CDR (lra);
916 while (1)
917 {
918 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
919 if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
920 return SCM_UNSPECIFIED;
921 lra = SCM_CDR (lra);
922 }
923 }
924 scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
925 lra = SCM_CDR (lra);
926 if (SCM_NIMP (lra))
927 for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
928 scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
929 }
930 return SCM_UNSPECIFIED;
931 }
932 }
933 #undef FUNC_NAME
934
935
936 static int
rafe(SCM ra0,SCM proc,SCM ras)937 rafe (SCM ra0, SCM proc, SCM ras)
938 {
939 long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
940 unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
941 long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
942 long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
943 ra0 = SCM_I_ARRAY_V (ra0);
944 if (scm_is_null (ras))
945 for (; i <= n; i++, i0 += inc0)
946 scm_call_1 (proc, GVREF (ra0, i0));
947 else
948 {
949 SCM ra1 = SCM_CAR (ras);
950 SCM args;
951 unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
952 long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
953 ra1 = SCM_I_ARRAY_V (ra1);
954 ras = SCM_CDR (ras);
955 if (scm_is_null(ras))
956 ras = scm_nullvect;
957 else
958 ras = scm_vector (ras);
959 for (; i <= n; i++, i0 += inc0, i1 += inc1)
960 {
961 args = SCM_EOL;
962 for (k = scm_c_vector_length (ras); k--;)
963 args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
964 args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
965 scm_apply_0 (proc, args);
966 }
967 }
968 return 1;
969 }
970
971
972 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
973 (SCM proc, SCM ra0, SCM lra),
974 "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
975 "in row-major order. The value returned is unspecified.")
976 #define FUNC_NAME s_scm_array_for_each
977 {
978 SCM_VALIDATE_PROC (1, proc);
979 SCM_VALIDATE_REST_ARGUMENT (lra);
980 scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
981 return SCM_UNSPECIFIED;
982 }
983 #undef FUNC_NAME
984
985 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
986 (SCM ra, SCM proc),
987 "Apply @var{proc} to the indices of each element of @var{array} in\n"
988 "turn, storing the result in the corresponding element. The value\n"
989 "returned and the order of application are unspecified.\n\n"
990 "One can implement @var{array-indexes} as\n"
991 "@lisp\n"
992 "(define (array-indexes array)\n"
993 " (let ((ra (apply make-array #f (array-shape array))))\n"
994 " (array-index-map! ra (lambda x x))\n"
995 " ra))\n"
996 "@end lisp\n"
997 "Another example:\n"
998 "@lisp\n"
999 "(define (apl:index-generator n)\n"
1000 " (let ((v (make-uniform-vector n 1)))\n"
1001 " (array-index-map! v (lambda (i) i))\n"
1002 " v))\n"
1003 "@end lisp")
1004 #define FUNC_NAME s_scm_array_index_map_x
1005 {
1006 unsigned long i;
1007 SCM_VALIDATE_PROC (2, proc);
1008
1009 if (SCM_I_ARRAYP (ra))
1010 {
1011 SCM args = SCM_EOL;
1012 int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
1013 long *vinds;
1014
1015 if (kmax < 0)
1016 return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
1017
1018 scm_dynwind_begin (0);
1019
1020 vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
1021 scm_dynwind_free (vinds);
1022
1023 for (k = 0; k <= kmax; k++)
1024 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1025 k = kmax;
1026 do
1027 {
1028 if (k == kmax)
1029 {
1030 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1031 i = cind (ra, vinds);
1032 for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
1033 {
1034 for (j = kmax + 1, args = SCM_EOL; j--;)
1035 args = scm_cons (scm_from_long (vinds[j]), args);
1036 GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
1037 i += SCM_I_ARRAY_DIMS (ra)[k].inc;
1038 }
1039 k--;
1040 continue;
1041 }
1042 if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
1043 {
1044 vinds[k]++;
1045 k++;
1046 continue;
1047 }
1048 vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
1049 k--;
1050 }
1051 while (k >= 0);
1052
1053 scm_dynwind_end ();
1054 return SCM_UNSPECIFIED;
1055 }
1056 else if (scm_is_generalized_vector (ra))
1057 {
1058 size_t length = scm_c_generalized_vector_length (ra);
1059 for (i = 0; i < length; i++)
1060 GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
1061 return SCM_UNSPECIFIED;
1062 }
1063 else
1064 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1065 }
1066 #undef FUNC_NAME
1067
1068
1069 static int
raeql_1(SCM ra0,SCM as_equal,SCM ra1)1070 raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
1071 {
1072 unsigned long i0 = 0, i1 = 0;
1073 long inc0 = 1, inc1 = 1;
1074 unsigned long n;
1075 ra1 = SCM_CAR (ra1);
1076 if (SCM_I_ARRAYP(ra0))
1077 {
1078 n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
1079 i0 = SCM_I_ARRAY_BASE (ra0);
1080 inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
1081 ra0 = SCM_I_ARRAY_V (ra0);
1082 }
1083 else
1084 n = scm_c_generalized_vector_length (ra0);
1085
1086 if (SCM_I_ARRAYP (ra1))
1087 {
1088 i1 = SCM_I_ARRAY_BASE (ra1);
1089 inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
1090 ra1 = SCM_I_ARRAY_V (ra1);
1091 }
1092
1093 if (scm_is_generalized_vector (ra0))
1094 {
1095 for (; n--; i0 += inc0, i1 += inc1)
1096 {
1097 if (scm_is_false (as_equal))
1098 {
1099 if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
1100 return 0;
1101 }
1102 else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
1103 return 0;
1104 }
1105 return 1;
1106 }
1107 else
1108 return 0;
1109 }
1110
1111
1112
1113 static int
raeql(SCM ra0,SCM as_equal,SCM ra1)1114 raeql (SCM ra0, SCM as_equal, SCM ra1)
1115 {
1116 SCM v0 = ra0, v1 = ra1;
1117 scm_t_array_dim dim0, dim1;
1118 scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
1119 unsigned long bas0 = 0, bas1 = 0;
1120 int k, unroll = 1, vlen = 1, ndim = 1;
1121 if (SCM_I_ARRAYP (ra0))
1122 {
1123 ndim = SCM_I_ARRAY_NDIM (ra0);
1124 s0 = SCM_I_ARRAY_DIMS (ra0);
1125 bas0 = SCM_I_ARRAY_BASE (ra0);
1126 v0 = SCM_I_ARRAY_V (ra0);
1127 }
1128 else
1129 {
1130 s0->inc = 1;
1131 s0->lbnd = 0;
1132 s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
1133 unroll = 0;
1134 }
1135 if (SCM_I_ARRAYP (ra1))
1136 {
1137 if (ndim != SCM_I_ARRAY_NDIM (ra1))
1138 return 0;
1139 s1 = SCM_I_ARRAY_DIMS (ra1);
1140 bas1 = SCM_I_ARRAY_BASE (ra1);
1141 v1 = SCM_I_ARRAY_V (ra1);
1142 }
1143 else
1144 {
1145 /*
1146 Huh ? Schizophrenic return type. --hwn
1147 */
1148 if (1 != ndim)
1149 return 0;
1150 s1->inc = 1;
1151 s1->lbnd = 0;
1152 s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
1153 unroll = 0;
1154 }
1155 if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
1156 return 0;
1157 for (k = ndim; k--;)
1158 {
1159 if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
1160 return 0;
1161 if (unroll)
1162 {
1163 unroll = (s0[k].inc == s1[k].inc);
1164 vlen *= s0[k].ubnd - s1[k].lbnd + 1;
1165 }
1166 }
1167 if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
1168 return 1;
1169 return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
1170 }
1171
1172
1173 SCM
scm_raequal(SCM ra0,SCM ra1)1174 scm_raequal (SCM ra0, SCM ra1)
1175 {
1176 return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
1177 }
1178
1179 #if 0
1180 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1181 SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
1182 (SCM ra0, SCM ra1),
1183 "Return @code{#t} iff all arguments are arrays with the same\n"
1184 "shape, the same type, and have corresponding elements which are\n"
1185 "either @code{equal?} or @code{array-equal?}. This function\n"
1186 "differs from @code{equal?} in that a one dimensional shared\n"
1187 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1188 "vector or uniform vector.")
1189 #define FUNC_NAME s_scm_array_equal_p
1190 {
1191 }
1192 #undef FUNC_NAME
1193 #endif
1194
1195 static char s_array_equal_p[] = "array-equal?";
1196
1197
1198 SCM
scm_array_equal_p(SCM ra0,SCM ra1)1199 scm_array_equal_p (SCM ra0, SCM ra1)
1200 {
1201 if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
1202 return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
1203 return scm_equal_p (ra0, ra1);
1204 }
1205
1206
1207 static void
init_raprocs(ra_iproc * subra)1208 init_raprocs (ra_iproc *subra)
1209 {
1210 for (; subra->name; subra++)
1211 {
1212 SCM sym = scm_from_locale_symbol (subra->name);
1213 SCM var =
1214 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
1215 if (var != SCM_BOOL_F)
1216 subra->sproc = SCM_VARIABLE_REF (var);
1217 else
1218 subra->sproc = SCM_BOOL_F;
1219 }
1220 }
1221
1222
1223 void
scm_init_ramap()1224 scm_init_ramap ()
1225 {
1226 init_raprocs (ra_rpsubrs);
1227 init_raprocs (ra_asubrs);
1228 scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
1229 scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
1230 #include "libguile/ramap.x"
1231 scm_add_feature (s_scm_array_for_each);
1232 }
1233
1234 /*
1235 Local Variables:
1236 c-file-style: "gnu"
1237 End:
1238 */
1239