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