1 /* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
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.
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.
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
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/generalized-arrays.h"
41 #include "libguile/generalized-vectors.h"
43 #include "libguile/validate.h"
44 #include "libguile/array-map.h"
47 /* The WHAT argument for `scm_gc_malloc ()' et al. */
48 static const char indices_gc_hint
[] = "array-indices";
51 #define GVREF scm_c_generalized_vector_ref
52 #define GVSET scm_c_generalized_vector_set_x
55 cind (SCM ra
, long *ve
)
59 if (!SCM_I_ARRAYP (ra
))
61 i
= SCM_I_ARRAY_BASE (ra
);
62 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
63 i
+= (ve
[k
] - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
68 /* Checker for scm_array mapping functions:
69 return values: 4 --> shapes, increments, and bases are the same;
70 3 --> shapes and increments are the same;
71 2 --> shapes are the same;
72 1 --> ras are at least as big as ra0;
77 scm_ra_matchp (SCM ra0
, SCM ras
)
81 scm_t_array_dim
*s0
= &dims
;
83 unsigned long bas0
= 0;
85 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
87 if (scm_is_generalized_vector (ra0
))
91 s0
->ubnd
= scm_c_generalized_vector_length (ra0
) - 1;
93 else if (SCM_I_ARRAYP (ra0
))
95 ndim
= SCM_I_ARRAY_NDIM (ra0
);
96 s0
= SCM_I_ARRAY_DIMS (ra0
);
97 bas0
= SCM_I_ARRAY_BASE (ra0
);
102 while (scm_is_pair (ras
))
106 if (scm_is_generalized_vector (ra1
))
113 length
= scm_c_generalized_vector_length (ra1
);
124 if ((0 == s0
->lbnd
) && (s0
->ubnd
== length
- 1))
128 if (s0
->lbnd
< 0 || s0
->ubnd
>= length
)
132 else if (SCM_I_ARRAYP (ra1
) && ndim
== SCM_I_ARRAY_NDIM (ra1
))
134 s1
= SCM_I_ARRAY_DIMS (ra1
);
135 if (bas0
!= SCM_I_ARRAY_BASE (ra1
))
137 for (i
= 0; i
< ndim
; i
++)
142 if (s0
[i
].inc
!= s1
[i
].inc
)
145 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
149 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
150 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
162 /* array mapper: apply cproc to each dimension of the given arrays?.
163 int (*cproc) (); procedure to call on unrolled arrays?
164 cproc (dest, source list) or
165 cproc (dest, data, source list).
166 SCM data; data to give to cproc or unbound.
167 SCM ra0; destination array.
168 SCM lra; list of source arrays.
169 const char *what; caller, for error reporting. */
171 scm_ramapc (void *cproc_ptr
, SCM data
, SCM ra0
, SCM lra
, const char *what
)
181 switch (scm_ra_matchp (ra0
, lra
))
185 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
188 case 4: /* Try unrolling arrays */
189 kmax
= (SCM_I_ARRAYP (ra0
) ? SCM_I_ARRAY_NDIM (ra0
) - 1 : 0);
192 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
193 if (SCM_IMP (vra0
)) goto gencase
;
194 if (!SCM_I_ARRAYP (vra0
))
196 size_t length
= scm_c_generalized_vector_length (vra0
);
197 vra1
= scm_i_make_array (1);
198 SCM_I_ARRAY_BASE (vra1
) = 0;
199 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= 0;
200 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= length
- 1;
201 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
202 SCM_I_ARRAY_V (vra1
) = vra0
;
207 for (z
= lra
; scm_is_pair (z
); z
= SCM_CDR (z
))
210 vra1
= scm_i_make_array (1);
211 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= SCM_I_ARRAY_DIMS (vra0
)->lbnd
;
212 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= SCM_I_ARRAY_DIMS (vra0
)->ubnd
;
213 if (!SCM_I_ARRAYP (ra1
))
215 SCM_I_ARRAY_BASE (vra1
) = 0;
216 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
217 SCM_I_ARRAY_V (vra1
) = ra1
;
219 else if (!SCM_I_ARRAY_CONTP (ra1
))
223 SCM_I_ARRAY_BASE (vra1
) = SCM_I_ARRAY_BASE (ra1
);
224 SCM_I_ARRAY_DIMS (vra1
)->inc
= SCM_I_ARRAY_DIMS (ra1
)[kmax
].inc
;
225 SCM_I_ARRAY_V (vra1
) = SCM_I_ARRAY_V (ra1
);
227 *plvra
= scm_cons (vra1
, SCM_EOL
);
228 plvra
= SCM_CDRLOC (*plvra
);
230 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
232 gencase
: /* Have to loop over all dimensions. */
233 vra0
= scm_i_make_array (1);
234 if (SCM_I_ARRAYP (ra0
))
236 kmax
= SCM_I_ARRAY_NDIM (ra0
) - 1;
239 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= 0;
240 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= 0;
241 SCM_I_ARRAY_DIMS (vra0
)->inc
= 1;
245 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
246 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
247 SCM_I_ARRAY_DIMS (vra0
)->inc
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].inc
;
249 SCM_I_ARRAY_BASE (vra0
) = SCM_I_ARRAY_BASE (ra0
);
250 SCM_I_ARRAY_V (vra0
) = SCM_I_ARRAY_V (ra0
);
254 size_t length
= scm_c_generalized_vector_length (ra0
);
256 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= 0;
257 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= length
- 1;
258 SCM_I_ARRAY_DIMS (vra0
)->inc
= 1;
259 SCM_I_ARRAY_BASE (vra0
) = 0;
260 SCM_I_ARRAY_V (vra0
) = ra0
;
265 for (z
= lra
; scm_is_pair (z
); z
= SCM_CDR (z
))
268 vra1
= scm_i_make_array (1);
269 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= SCM_I_ARRAY_DIMS (vra0
)->lbnd
;
270 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= SCM_I_ARRAY_DIMS (vra0
)->ubnd
;
271 if (SCM_I_ARRAYP (ra1
))
274 SCM_I_ARRAY_DIMS (vra1
)->inc
= SCM_I_ARRAY_DIMS (ra1
)[kmax
].inc
;
275 SCM_I_ARRAY_V (vra1
) = SCM_I_ARRAY_V (ra1
);
279 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
280 SCM_I_ARRAY_V (vra1
) = ra1
;
282 *plvra
= scm_cons (vra1
, SCM_EOL
);
283 plvra
= SCM_CDRLOC (*plvra
);
286 vinds
= scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0
),
289 for (k
= 0; k
<= kmax
; k
++)
290 vinds
[k
] = SCM_I_ARRAY_DIMS (ra0
)[k
].lbnd
;
297 SCM_I_ARRAY_BASE (vra0
) = cind (ra0
, vinds
);
298 for (z
= lvra
; scm_is_pair (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
299 SCM_I_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), vinds
);
300 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
305 if (vinds
[k
] < SCM_I_ARRAY_DIMS (ra0
)[k
].ubnd
)
311 vinds
[k
] = SCM_I_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
321 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
323 "Store @var{fill} in every element of array @var{ra}. The value\n"
324 "returned is unspecified.")
325 #define FUNC_NAME s_scm_array_fill_x
327 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
328 return SCM_UNSPECIFIED
;
332 /* to be used as cproc in scm_ramapc to fill an array dimension with
335 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
336 #define FUNC_NAME s_scm_array_fill_x
339 unsigned long n
= SCM_I_ARRAY_DIMS (ra
)->ubnd
- SCM_I_ARRAY_DIMS (ra
)->lbnd
+ 1;
340 long inc
= SCM_I_ARRAY_DIMS (ra
)->inc
;
341 unsigned long base
= SCM_I_ARRAY_BASE (ra
);
343 ra
= SCM_I_ARRAY_V (ra
);
345 for (i
= base
; n
--; i
+= inc
)
355 racp (SCM src
, SCM dst
)
357 long n
= (SCM_I_ARRAY_DIMS (src
)->ubnd
- SCM_I_ARRAY_DIMS (src
)->lbnd
+ 1);
358 long inc_d
, inc_s
= SCM_I_ARRAY_DIMS (src
)->inc
;
359 unsigned long i_d
, i_s
= SCM_I_ARRAY_BASE (src
);
361 inc_d
= SCM_I_ARRAY_DIMS (dst
)->inc
;
362 i_d
= SCM_I_ARRAY_BASE (dst
);
363 src
= SCM_I_ARRAY_V (src
);
364 dst
= SCM_I_ARRAY_V (dst
);
366 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
367 GVSET (dst
, i_d
, GVREF (src
, i_s
));
371 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
374 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
376 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
377 "Copy every element from vector or array @var{src} to the\n"
378 "corresponding element of @var{dst}. @var{dst} must have the\n"
379 "same rank as @var{src}, and be at least as large in each\n"
380 "dimension. The order is unspecified.")
381 #define FUNC_NAME s_scm_array_copy_x
383 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
384 return SCM_UNSPECIFIED
;
388 /* Functions callable by ARRAY-MAP! */
392 scm_ra_eqp (SCM ra0
, SCM ras
)
394 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
395 scm_t_array_handle ra0_handle
;
396 scm_t_array_dim
*ra0_dims
;
400 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
401 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
402 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
403 ra1
= SCM_I_ARRAY_V (ra1
);
404 ra2
= SCM_I_ARRAY_V (ra2
);
406 scm_array_get_handle (ra0
, &ra0_handle
);
407 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
408 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
409 inc0
= ra0_dims
[0].inc
;
412 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
413 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
414 if (!scm_is_eq (GVREF (ra1
, i1
), GVREF (ra2
, i2
)))
415 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
418 scm_array_handle_release (&ra0_handle
);
422 /* opt 0 means <, nonzero means >= */
425 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
427 scm_t_array_handle ra0_handle
;
428 scm_t_array_dim
*ra0_dims
;
432 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
433 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
434 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
435 ra1
= SCM_I_ARRAY_V (ra1
);
436 ra2
= SCM_I_ARRAY_V (ra2
);
438 scm_array_get_handle (ra0
, &ra0_handle
);
439 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
440 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
441 inc0
= ra0_dims
[0].inc
;
444 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
445 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
447 scm_is_true (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))) :
448 scm_is_false (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))))
449 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
452 scm_array_handle_release (&ra0_handle
);
459 scm_ra_lessp (SCM ra0
, SCM ras
)
461 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
466 scm_ra_leqp (SCM ra0
, SCM ras
)
468 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
473 scm_ra_grp (SCM ra0
, SCM ras
)
475 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
480 scm_ra_greqp (SCM ra0
, SCM ras
)
482 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
487 scm_ra_sum (SCM ra0
, SCM ras
)
489 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
490 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
491 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
492 ra0
= SCM_I_ARRAY_V (ra0
);
493 if (!scm_is_null(ras
))
495 SCM ra1
= SCM_CAR (ras
);
496 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
497 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
498 ra1
= SCM_I_ARRAY_V (ra1
);
499 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
503 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
504 GVSET (ra0
, i0
, scm_sum (GVREF(ra0
, i0
), GVREF(ra1
, i1
)));
515 scm_ra_difference (SCM ra0
, SCM ras
)
517 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
518 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
519 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
520 ra0
= SCM_I_ARRAY_V (ra0
);
521 if (scm_is_null (ras
))
523 switch (SCM_TYP7 (ra0
))
527 for (; n
-- > 0; i0
+= inc0
)
528 GVSET (ra0
, i0
, scm_difference (GVREF(ra0
, i0
), SCM_UNDEFINED
));
535 SCM ra1
= SCM_CAR (ras
);
536 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
537 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
538 ra1
= SCM_I_ARRAY_V (ra1
);
539 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
543 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
544 GVSET (ra0
, i0
, scm_difference (GVREF (ra0
, i0
),
556 scm_ra_product (SCM ra0
, SCM ras
)
558 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
559 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
560 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
561 ra0
= SCM_I_ARRAY_V (ra0
);
562 if (!scm_is_null (ras
))
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)
572 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
573 GVSET (ra0
, i0
, scm_product (GVREF (ra0
, i0
),
583 scm_ra_divide (SCM ra0
, SCM ras
)
585 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
586 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
587 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
588 ra0
= SCM_I_ARRAY_V (ra0
);
589 if (scm_is_null (ras
))
591 switch (SCM_TYP7 (ra0
))
595 for (; n
-- > 0; i0
+= inc0
)
596 GVSET (ra0
, i0
, scm_divide (GVREF (ra0
, i0
), SCM_UNDEFINED
));
603 SCM ra1
= SCM_CAR (ras
);
604 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
605 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
606 ra1
= SCM_I_ARRAY_V (ra1
);
607 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
611 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
613 SCM res
= scm_divide (GVREF (ra0
, i0
),
615 GVSET (ra0
, i0
, res
);
626 scm_array_identity (SCM dst
, SCM src
)
628 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
634 ramap (SCM ra0
, SCM proc
, SCM ras
)
636 long i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
637 long inc
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
638 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
;
639 long base
= SCM_I_ARRAY_BASE (ra0
) - i
* inc
;
640 ra0
= SCM_I_ARRAY_V (ra0
);
641 if (scm_is_null (ras
))
643 GVSET (ra0
, i
*inc
+base
, scm_call_0 (proc
));
646 SCM ra1
= SCM_CAR (ras
);
648 unsigned long k
, i1
= SCM_I_ARRAY_BASE (ra1
);
649 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
650 ra1
= SCM_I_ARRAY_V (ra1
);
651 ras
= scm_vector (SCM_CDR (ras
));
653 for (; i
<= n
; i
++, i1
+= inc1
)
656 for (k
= scm_c_vector_length (ras
); k
--;)
657 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
658 args
= scm_cons (GVREF (ra1
, i1
), args
);
659 GVSET (ra0
, i
*inc
+base
, scm_apply_0 (proc
, args
));
666 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
668 SCM_SYMBOL (sym_b
, "b");
670 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
671 (SCM ra0
, SCM proc
, SCM lra
),
672 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
673 "@var{array1}, @dots{} must have the same number of dimensions\n"
674 "as @var{ra0} and have a range for each index which includes the\n"
675 "range for the corresponding index in @var{ra0}. @var{proc} is\n"
676 "applied to each tuple of elements of @var{array1}, @dots{} and\n"
677 "the result is stored as the corresponding element in @var{ra0}.\n"
678 "The value returned is unspecified. The order of application is\n"
680 #define FUNC_NAME s_scm_array_map_x
682 SCM_VALIDATE_PROC (2, proc
);
683 SCM_VALIDATE_REST_ARGUMENT (lra
);
685 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
686 return SCM_UNSPECIFIED
;
692 rafe (SCM ra0
, SCM proc
, SCM ras
)
694 long i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
695 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
696 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
697 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
;
698 ra0
= SCM_I_ARRAY_V (ra0
);
699 if (scm_is_null (ras
))
700 for (; i
<= n
; i
++, i0
+= inc0
)
701 scm_call_1 (proc
, GVREF (ra0
, i0
));
704 SCM ra1
= SCM_CAR (ras
);
706 unsigned long k
, i1
= SCM_I_ARRAY_BASE (ra1
);
707 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
708 ra1
= SCM_I_ARRAY_V (ra1
);
709 ras
= scm_vector (SCM_CDR (ras
));
711 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
714 for (k
= scm_c_vector_length (ras
); k
--;)
715 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
716 args
= scm_cons2 (GVREF (ra0
, i0
), GVREF (ra1
, i1
), args
);
717 scm_apply_0 (proc
, args
);
724 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
725 (SCM proc
, SCM ra0
, SCM lra
),
726 "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
727 "in row-major order. The value returned is unspecified.")
728 #define FUNC_NAME s_scm_array_for_each
730 SCM_VALIDATE_PROC (1, proc
);
731 SCM_VALIDATE_REST_ARGUMENT (lra
);
732 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
733 return SCM_UNSPECIFIED
;
737 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
739 "Apply @var{proc} to the indices of each element of @var{ra} in\n"
740 "turn, storing the result in the corresponding element. The value\n"
741 "returned and the order of application are unspecified.\n\n"
742 "One can implement @var{array-indexes} as\n"
744 "(define (array-indexes array)\n"
745 " (let ((ra (apply make-array #f (array-shape array))))\n"
746 " (array-index-map! ra (lambda x x))\n"
751 "(define (apl:index-generator n)\n"
752 " (let ((v (make-uniform-vector n 1)))\n"
753 " (array-index-map! v (lambda (i) i))\n"
756 #define FUNC_NAME s_scm_array_index_map_x
759 SCM_VALIDATE_PROC (2, proc
);
761 if (SCM_I_ARRAYP (ra
))
764 int j
, k
, kmax
= SCM_I_ARRAY_NDIM (ra
) - 1;
768 return scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
770 vinds
= scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra
),
773 for (k
= 0; k
<= kmax
; k
++)
774 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
780 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
781 i
= cind (ra
, vinds
);
782 for (; vinds
[k
] <= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
784 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
785 args
= scm_cons (scm_from_long (vinds
[j
]), args
);
786 GVSET (SCM_I_ARRAY_V (ra
), i
, scm_apply_0 (proc
, args
));
787 i
+= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
792 if (vinds
[k
] < SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
)
798 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
803 return SCM_UNSPECIFIED
;
805 else if (scm_is_generalized_vector (ra
))
807 size_t length
= scm_c_generalized_vector_length (ra
);
808 for (i
= 0; i
< length
; i
++)
809 GVSET (ra
, i
, scm_call_1 (proc
, scm_from_ulong (i
)));
810 return SCM_UNSPECIFIED
;
813 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
819 array_compare (scm_t_array_handle
*hx
, scm_t_array_handle
*hy
,
820 size_t dim
, unsigned long posx
, unsigned long posy
)
822 if (dim
== scm_array_handle_rank (hx
))
823 return scm_is_true (scm_equal_p (scm_array_handle_ref (hx
, posx
),
824 scm_array_handle_ref (hy
, posy
)));
830 if (hx
->dims
[dim
].lbnd
!= hy
->dims
[dim
].lbnd
831 || hx
->dims
[dim
].ubnd
!= hy
->dims
[dim
].ubnd
)
834 i
= hx
->dims
[dim
].ubnd
- hx
->dims
[dim
].lbnd
+ 1;
836 incx
= hx
->dims
[dim
].inc
;
837 incy
= hy
->dims
[dim
].inc
;
838 posx
+= (i
- 1) * incx
;
839 posy
+= (i
- 1) * incy
;
841 for (; i
> 0; i
--, posx
-= incx
, posy
-= incy
)
842 if (!array_compare (hx
, hy
, dim
+ 1, posx
, posy
))
849 scm_array_equal_p (SCM x
, SCM y
)
851 scm_t_array_handle hx
, hy
;
854 scm_array_get_handle (x
, &hx
);
855 scm_array_get_handle (y
, &hy
);
857 res
= scm_from_bool (hx
.ndims
== hy
.ndims
858 && hx
.element_type
== hy
.element_type
);
860 if (scm_is_true (res
))
861 res
= scm_from_bool (array_compare (&hx
, &hy
, 0, 0, 0));
863 scm_array_handle_release (&hy
);
864 scm_array_handle_release (&hx
);
869 static SCM
scm_i_array_equal_p (SCM
, SCM
, SCM
);
870 SCM_DEFINE (scm_i_array_equal_p
, "array-equal?", 0, 2, 1,
871 (SCM ra0
, SCM ra1
, SCM rest
),
872 "Return @code{#t} iff all arguments are arrays with the same\n"
873 "shape, the same type, and have corresponding elements which are\n"
874 "either @code{equal?} or @code{array-equal?}. This function\n"
875 "differs from @code{equal?} in that all arguments must be arrays.")
876 #define FUNC_NAME s_scm_i_array_equal_p
878 if (SCM_UNBNDP (ra0
) || SCM_UNBNDP (ra1
))
881 while (!scm_is_null (rest
))
882 { if (scm_is_false (scm_array_equal_p (ra0
, ra1
)))
885 ra1
= scm_car (rest
);
886 rest
= scm_cdr (rest
);
888 return scm_array_equal_p (ra0
, ra1
);
894 scm_init_array_map (void)
896 #include "libguile/array-map.x"
897 scm_add_feature (s_scm_array_for_each
);