1 /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
2 * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
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.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
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
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/strings.h"
31 #include "libguile/arrays.h"
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"
39 #include "libguile/bitvectors.h"
40 #include "libguile/srfi-4.h"
41 #include "libguile/generalized-arrays.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 vi_gc_hint
[] = "array-indices";
51 AREF (SCM v
, size_t pos
)
53 return scm_c_array_ref_1 (v
, pos
);
57 ASET (SCM v
, size_t pos
, SCM val
)
59 scm_c_array_set_1_x (v
, val
, pos
);
63 make1array (SCM v
, ssize_t inc
)
65 SCM a
= scm_i_make_array (1);
66 SCM_I_ARRAY_BASE (a
) = 0;
67 SCM_I_ARRAY_DIMS (a
)->lbnd
= 0;
68 SCM_I_ARRAY_DIMS (a
)->ubnd
= scm_c_array_length (v
) - 1;
69 SCM_I_ARRAY_DIMS (a
)->inc
= inc
;
70 SCM_I_ARRAY_V (a
) = v
;
74 /* Linear index of not-unrolled index set. */
76 cindk (SCM ra
, ssize_t
*ve
, int kend
)
78 if (SCM_I_ARRAYP (ra
))
81 size_t i
= SCM_I_ARRAY_BASE (ra
);
82 for (k
= 0; k
< kend
; ++k
)
83 i
+= (ve
[k
] - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
87 return 0; /* this is BASE */
90 /* array mapper: apply cproc to each dimension of the given arrays?.
91 int (*cproc) (); procedure to call on unrolled arrays?
92 cproc (dest, source list) or
93 cproc (dest, data, source list).
94 SCM data; data to give to cproc or unbound.
95 SCM ra0; destination array.
96 SCM lra; list of source arrays.
97 const char *what; caller, for error reporting. */
99 #define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
100 #define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
103 scm_ramapc (void *cproc_ptr
, SCM data
, SCM ra0
, SCM lra
, const char *what
)
105 int (*cproc
) () = cproc_ptr
;
106 SCM z
, va0
, lva
, *plva
;
111 /* Prepare reference argument. */
112 if (SCM_I_ARRAYP (ra0
))
114 kmax
= SCM_I_ARRAY_NDIM (ra0
)-1;
115 inc
= kmax
< 0 ? 0 : SCM_I_ARRAY_DIMS (ra0
)[kmax
].inc
;
116 va0
= make1array (SCM_I_ARRAY_V (ra0
), inc
);
118 /* Find unroll depth */
119 for (kroll
= max(0, kmax
); kroll
> 0; --kroll
)
121 inc
*= (UBND (ra0
, kroll
) - LBND (ra0
, kroll
) + 1);
122 if (inc
!= SCM_I_ARRAY_DIMS (ra0
)[kroll
-1].inc
)
129 va0
= ra0
= make1array (ra0
, 1);
132 /* Prepare rest arguments. */
135 for (z
= lra
; !scm_is_null (z
); z
= SCM_CDR (z
))
137 SCM va1
, ra1
= SCM_CAR (z
);
138 if (SCM_I_ARRAYP (ra1
))
140 if (kmax
!= SCM_I_ARRAY_NDIM (ra1
) - 1)
141 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
142 inc
= kmax
< 0 ? 0 : SCM_I_ARRAY_DIMS (ra1
)[kmax
].inc
;
143 va1
= make1array (SCM_I_ARRAY_V (ra1
), inc
);
145 /* Check unroll depth. */
146 for (k
= kmax
; k
> kroll
; --k
)
148 ssize_t l0
= LBND (ra0
, k
), u0
= UBND (ra0
, k
);
149 if (l0
< LBND (ra1
, k
) || u0
> UBND (ra1
, k
))
150 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
151 inc
*= (u0
- l0
+ 1);
152 if (inc
!= SCM_I_ARRAY_DIMS (ra1
)[k
-1].inc
)
159 /* Check matching of not-unrolled axes. */
161 if (LBND (ra0
, k
) < LBND (ra1
, k
) || UBND (ra0
, k
) > UBND (ra1
, k
))
162 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
167 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
168 va1
= make1array (ra1
, 1);
170 if (LBND (ra0
, 0) < LBND (va1
, 0) || UBND (ra0
, 0) > UBND (va1
, 0))
171 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
173 *plva
= scm_cons (va1
, SCM_EOL
);
174 plva
= SCM_CDRLOC (*plva
);
177 /* Check emptiness of not-unrolled axes. */
178 for (k
= 0; k
< kroll
; ++k
)
179 if (0 == (UBND (ra0
, k
) - LBND (ra0
, k
) + 1))
182 /* Set unrolled size. */
183 for (len
= 1; k
<= kmax
; ++k
)
184 len
*= (UBND (ra0
, k
) - LBND (ra0
, k
) + 1);
185 UBND (va0
, 0) = len
- 1;
186 for (z
= lva
; !scm_is_null (z
); z
= SCM_CDR (z
))
187 UBND (SCM_CAR (z
), 0) = len
- 1;
189 /* Set starting indices and go. */
190 vi
= scm_gc_malloc_pointerless (sizeof(ssize_t
) * kroll
, vi_gc_hint
);
191 for (k
= 0; k
< kroll
; ++k
)
192 vi
[k
] = LBND (ra0
, k
);
198 SCM_I_ARRAY_BASE (va0
) = cindk (ra0
, vi
, kroll
);
199 for (z
= lva
; !scm_is_null (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
200 SCM_I_ARRAY_BASE (SCM_CAR (z
)) = cindk (SCM_CAR (y
), vi
, kroll
);
201 if (! (SCM_UNBNDP (data
) ? cproc (va0
, lva
) : cproc (va0
, data
, lva
)))
205 else if (vi
[k
] < UBND (ra0
, k
))
212 vi
[k
] = LBND (ra0
, k
) - 1;
225 rafill (SCM dst
, SCM fill
)
227 scm_t_array_handle h
;
230 scm_array_get_handle (SCM_I_ARRAY_V (dst
), &h
);
231 i
= SCM_I_ARRAY_BASE (dst
);
232 inc
= SCM_I_ARRAY_DIMS (dst
)->inc
;
233 n
= (SCM_I_ARRAY_DIMS (dst
)->ubnd
- SCM_I_ARRAY_DIMS (dst
)->lbnd
+ 1);
234 dst
= SCM_I_ARRAY_V (dst
);
236 for (; n
-- > 0; i
+= inc
)
237 h
.vset (h
.vector
, i
, fill
);
239 scm_array_handle_release (&h
);
243 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
245 "Store @var{fill} in every element of array @var{ra}. The value\n"
246 "returned is unspecified.")
247 #define FUNC_NAME s_scm_array_fill_x
249 scm_ramapc (rafill
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
250 return SCM_UNSPECIFIED
;
256 racp (SCM src
, SCM dst
)
258 scm_t_array_handle h_s
, h_d
;
260 ssize_t inc_s
, inc_d
;
263 i_s
= SCM_I_ARRAY_BASE (src
);
264 i_d
= SCM_I_ARRAY_BASE (dst
);
265 inc_s
= SCM_I_ARRAY_DIMS (src
)->inc
;
266 inc_d
= SCM_I_ARRAY_DIMS (dst
)->inc
;
267 n
= (SCM_I_ARRAY_DIMS (src
)->ubnd
- SCM_I_ARRAY_DIMS (src
)->lbnd
+ 1);
268 src
= SCM_I_ARRAY_V (src
);
269 dst
= SCM_I_ARRAY_V (dst
);
271 scm_array_get_handle (src
, &h_s
);
272 scm_array_get_handle (dst
, &h_d
);
274 if (h_s
.element_type
== SCM_ARRAY_ELEMENT_TYPE_SCM
275 && h_d
.element_type
== SCM_ARRAY_ELEMENT_TYPE_SCM
)
277 SCM
const * el_s
= h_s
.elements
;
278 SCM
* el_d
= h_d
.writable_elements
;
279 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
280 el_d
[i_d
] = el_s
[i_s
];
283 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
284 h_d
.vset (h_d
.vector
, i_d
, h_s
.vref (h_s
.vector
, i_s
));
286 scm_array_handle_release (&h_d
);
287 scm_array_handle_release (&h_s
);
292 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
295 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
297 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
298 "Copy every element from vector or array @var{src} to the\n"
299 "corresponding element of @var{dst}. @var{dst} must have the\n"
300 "same rank as @var{src}, and be at least as large in each\n"
301 "dimension. The order is unspecified.")
302 #define FUNC_NAME s_scm_array_copy_x
304 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
305 return SCM_UNSPECIFIED
;
310 #if SCM_ENABLE_DEPRECATED == 1
312 /* to be used as cproc in scm_ramapc to fill an array dimension with
315 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
318 unsigned long n
= SCM_I_ARRAY_DIMS (ra
)->ubnd
- SCM_I_ARRAY_DIMS (ra
)->lbnd
+ 1;
319 long inc
= SCM_I_ARRAY_DIMS (ra
)->inc
;
320 unsigned long base
= SCM_I_ARRAY_BASE (ra
);
322 ra
= SCM_I_ARRAY_V (ra
);
324 for (i
= base
; n
--; i
+= inc
)
330 /* Functions callable by ARRAY-MAP! */
333 scm_ra_eqp (SCM ra0
, SCM ras
)
335 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
336 scm_t_array_handle ra0_handle
;
337 scm_t_array_dim
*ra0_dims
;
341 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
342 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
343 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
344 ra1
= SCM_I_ARRAY_V (ra1
);
345 ra2
= SCM_I_ARRAY_V (ra2
);
347 scm_array_get_handle (ra0
, &ra0_handle
);
348 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
349 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
350 inc0
= ra0_dims
[0].inc
;
353 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
354 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
355 if (!scm_is_eq (AREF (ra1
, i1
), AREF (ra2
, i2
)))
356 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
359 scm_array_handle_release (&ra0_handle
);
363 /* opt 0 means <, nonzero means >= */
366 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
368 scm_t_array_handle ra0_handle
;
369 scm_t_array_dim
*ra0_dims
;
373 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
374 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
375 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
376 ra1
= SCM_I_ARRAY_V (ra1
);
377 ra2
= SCM_I_ARRAY_V (ra2
);
379 scm_array_get_handle (ra0
, &ra0_handle
);
380 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
381 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
382 inc0
= ra0_dims
[0].inc
;
385 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
386 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
388 scm_is_true (scm_less_p (AREF (ra1
, i1
), AREF (ra2
, i2
))) :
389 scm_is_false (scm_less_p (AREF (ra1
, i1
), AREF (ra2
, i2
))))
390 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
393 scm_array_handle_release (&ra0_handle
);
400 scm_ra_lessp (SCM ra0
, SCM ras
)
402 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
407 scm_ra_leqp (SCM ra0
, SCM ras
)
409 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
414 scm_ra_grp (SCM ra0
, SCM ras
)
416 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
421 scm_ra_greqp (SCM ra0
, SCM ras
)
423 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
428 scm_ra_sum (SCM ra0
, SCM ras
)
430 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
431 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
432 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
433 ra0
= SCM_I_ARRAY_V (ra0
);
434 if (!scm_is_null(ras
))
436 SCM ra1
= SCM_CAR (ras
);
437 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
438 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
439 ra1
= SCM_I_ARRAY_V (ra1
);
440 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
444 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
445 ASET (ra0
, i0
, scm_sum (AREF(ra0
, i0
), AREF(ra1
, i1
)));
456 scm_ra_difference (SCM ra0
, SCM ras
)
458 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
459 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
460 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
461 ra0
= SCM_I_ARRAY_V (ra0
);
462 if (scm_is_null (ras
))
464 switch (SCM_TYP7 (ra0
))
468 for (; n
-- > 0; i0
+= inc0
)
469 ASET (ra0
, i0
, scm_difference (AREF(ra0
, i0
), SCM_UNDEFINED
));
476 SCM ra1
= SCM_CAR (ras
);
477 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
478 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
479 ra1
= SCM_I_ARRAY_V (ra1
);
480 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
484 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
485 ASET (ra0
, i0
, scm_difference (AREF (ra0
, i0
), AREF (ra1
, i1
)));
496 scm_ra_product (SCM ra0
, SCM ras
)
498 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
499 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
500 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
501 ra0
= SCM_I_ARRAY_V (ra0
);
502 if (!scm_is_null (ras
))
504 SCM ra1
= SCM_CAR (ras
);
505 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
506 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
507 ra1
= SCM_I_ARRAY_V (ra1
);
508 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
512 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
513 ASET (ra0
, i0
, scm_product (AREF (ra0
, i0
), AREF (ra1
, i1
)));
522 scm_ra_divide (SCM ra0
, SCM ras
)
524 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
525 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
526 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
527 ra0
= SCM_I_ARRAY_V (ra0
);
528 if (scm_is_null (ras
))
530 switch (SCM_TYP7 (ra0
))
534 for (; n
-- > 0; i0
+= inc0
)
535 ASET (ra0
, i0
, scm_divide (AREF (ra0
, i0
), SCM_UNDEFINED
));
542 SCM ra1
= SCM_CAR (ras
);
543 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
544 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
545 ra1
= SCM_I_ARRAY_V (ra1
);
546 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
550 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
552 SCM res
= scm_divide (AREF (ra0
, i0
), AREF (ra1
, i1
));
564 scm_array_identity (SCM dst
, SCM src
)
566 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
569 #endif /* SCM_ENABLE_DEPRECATED */
572 ramap (SCM ra0
, SCM proc
, SCM ras
)
574 scm_t_array_handle h0
;
577 i0
= SCM_I_ARRAY_BASE (ra0
);
578 inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
579 i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
580 n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- i
+ 1;
581 ra0
= SCM_I_ARRAY_V (ra0
);
582 scm_array_get_handle (ra0
, &h0
);
583 if (scm_is_null (ras
))
584 for (; n
--; i0
+= inc0
)
585 h0
.vset (h0
.vector
, i0
, scm_call_0 (proc
));
588 SCM ra1
= SCM_CAR (ras
);
589 scm_t_array_handle h1
;
592 i1
= SCM_I_ARRAY_BASE (ra1
);
593 inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
595 ra1
= SCM_I_ARRAY_V (ra1
);
596 scm_array_get_handle (ra1
, &h1
);
597 if (scm_is_null (ras
))
598 for (; n
--; i0
+= inc0
, i1
+= inc1
)
599 h0
.vset (h0
.vector
, i0
, scm_call_1 (proc
, h1
.vref (h1
.vector
, i1
)));
602 ras
= scm_vector (ras
);
603 for (; n
--; i0
+= inc0
, i1
+= inc1
, ++i
)
607 for (k
= scm_c_vector_length (ras
); k
--;)
608 args
= scm_cons (AREF (scm_c_vector_ref (ras
, k
), i
), args
);
609 h0
.vset (h0
.vector
, i0
,
610 scm_apply_1 (proc
, h1
.vref (h1
.vector
, i1
), args
));
613 scm_array_handle_release (&h1
);
615 scm_array_handle_release (&h0
);
620 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
622 SCM_SYMBOL (sym_b
, "b");
624 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
625 (SCM ra0
, SCM proc
, SCM lra
),
626 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
627 "@var{array1}, @dots{} must have the same number of dimensions\n"
628 "as @var{ra0} and have a range for each index which includes the\n"
629 "range for the corresponding index in @var{ra0}. @var{proc} is\n"
630 "applied to each tuple of elements of @var{array1}, @dots{} and\n"
631 "the result is stored as the corresponding element in @var{ra0}.\n"
632 "The value returned is unspecified. The order of application is\n"
634 #define FUNC_NAME s_scm_array_map_x
636 SCM_VALIDATE_PROC (2, proc
);
637 SCM_VALIDATE_REST_ARGUMENT (lra
);
639 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
640 return SCM_UNSPECIFIED
;
646 rafe (SCM ra0
, SCM proc
, SCM ras
)
648 ssize_t i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
649 size_t n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- i
+ 1;
651 scm_t_array_handle h0
;
654 i0
= SCM_I_ARRAY_BASE (ra0
);
655 inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
656 ra0
= SCM_I_ARRAY_V (ra0
);
657 scm_array_get_handle (ra0
, &h0
);
658 if (scm_is_null (ras
))
659 for (; n
--; i0
+= inc0
)
660 scm_call_1 (proc
, h0
.vref (h0
.vector
, i0
));
663 ras
= scm_vector (ras
);
664 for (; n
--; i0
+= inc0
, ++i
)
668 for (k
= scm_c_vector_length (ras
); k
--;)
669 args
= scm_cons (AREF (scm_c_vector_ref (ras
, k
), i
), args
);
670 scm_apply_1 (proc
, h0
.vref (h0
.vector
, i0
), args
);
673 scm_array_handle_release (&h0
);
677 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
678 (SCM proc
, SCM ra0
, SCM lra
),
679 "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
680 "in row-major order. The value returned is unspecified.")
681 #define FUNC_NAME s_scm_array_for_each
683 SCM_VALIDATE_PROC (1, proc
);
684 SCM_VALIDATE_REST_ARGUMENT (lra
);
685 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
686 return SCM_UNSPECIFIED
;
691 array_index_map_1 (SCM ra
, SCM proc
)
693 scm_t_array_handle h
;
696 scm_array_get_handle (ra
, &h
);
698 for (i
= h
.dims
[0].lbnd
, p
= h
.base
; i
<= h
.dims
[0].ubnd
; ++i
, p
+= inc
)
699 h
.vset (h
.vector
, p
, scm_call_1 (proc
, scm_from_ssize_t (i
)));
700 scm_array_handle_release (&h
);
703 /* Here we assume that the array is a scm_tc7_array, as that is the only
704 kind of array in Guile that supports rank > 1. */
706 array_index_map_n (SCM ra
, SCM proc
)
708 scm_t_array_handle h
;
710 int k
, kmax
= SCM_I_ARRAY_NDIM (ra
) - 1;
716 vi
= scm_gc_malloc_pointerless (sizeof(ssize_t
) * (kmax
+ 1), vi_gc_hint
);
717 si
= scm_gc_malloc_pointerless (sizeof(SCM
*) * (kmax
+ 1), vi_gc_hint
);
719 for (k
= 0; k
<= kmax
; k
++)
721 vi
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
722 if (vi
[k
] > SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
)
724 *p
= scm_cons (scm_from_ssize_t (vi
[k
]), SCM_EOL
);
725 si
[k
] = SCM_CARLOC (*p
);
729 scm_array_get_handle (ra
, &h
);
735 vi
[kmax
] = SCM_I_ARRAY_DIMS (ra
)[kmax
].lbnd
;
736 i
= cindk (ra
, vi
, kmax
+1);
737 for (; vi
[kmax
] <= SCM_I_ARRAY_DIMS (ra
)[kmax
].ubnd
; ++vi
[kmax
])
739 *(si
[kmax
]) = scm_from_ssize_t (vi
[kmax
]);
740 h
.vset (h
.vector
, i
, scm_apply_0 (proc
, args
));
741 i
+= SCM_I_ARRAY_DIMS (ra
)[kmax
].inc
;
745 else if (vi
[k
] < SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
)
747 *(si
[k
]) = scm_from_ssize_t (++vi
[k
]);
752 vi
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
757 scm_array_handle_release (&h
);
760 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
762 "Apply @var{proc} to the indices of each element of @var{ra} in\n"
763 "turn, storing the result in the corresponding element. The value\n"
764 "returned and the order of application are unspecified.\n\n"
765 "One can implement @var{array-indexes} as\n"
767 "(define (array-indexes array)\n"
768 " (let ((ra (apply make-array #f (array-shape array))))\n"
769 " (array-index-map! ra (lambda x x))\n"
774 "(define (apl:index-generator n)\n"
775 " (let ((v (make-uniform-vector n 1)))\n"
776 " (array-index-map! v (lambda (i) i))\n"
779 #define FUNC_NAME s_scm_array_index_map_x
781 SCM_VALIDATE_PROC (2, proc
);
783 switch (scm_c_array_rank (ra
))
786 scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
789 array_index_map_1 (ra
, proc
);
792 array_index_map_n (ra
, proc
);
796 return SCM_UNSPECIFIED
;
802 array_compare (scm_t_array_handle
*hx
, scm_t_array_handle
*hy
,
803 size_t dim
, unsigned long posx
, unsigned long posy
)
805 if (dim
== scm_array_handle_rank (hx
))
806 return scm_is_true (scm_equal_p (scm_array_handle_ref (hx
, posx
),
807 scm_array_handle_ref (hy
, posy
)));
813 if (hx
->dims
[dim
].lbnd
!= hy
->dims
[dim
].lbnd
814 || hx
->dims
[dim
].ubnd
!= hy
->dims
[dim
].ubnd
)
817 i
= hx
->dims
[dim
].ubnd
- hx
->dims
[dim
].lbnd
+ 1;
819 incx
= hx
->dims
[dim
].inc
;
820 incy
= hy
->dims
[dim
].inc
;
821 posx
+= (i
- 1) * incx
;
822 posy
+= (i
- 1) * incy
;
824 for (; i
> 0; i
--, posx
-= incx
, posy
-= incy
)
825 if (!array_compare (hx
, hy
, dim
+ 1, posx
, posy
))
832 scm_array_equal_p (SCM x
, SCM y
)
834 scm_t_array_handle hx
, hy
;
837 scm_array_get_handle (x
, &hx
);
838 scm_array_get_handle (y
, &hy
);
840 res
= scm_from_bool (hx
.ndims
== hy
.ndims
841 && hx
.element_type
== hy
.element_type
);
843 if (scm_is_true (res
))
844 res
= scm_from_bool (array_compare (&hx
, &hy
, 0, 0, 0));
846 scm_array_handle_release (&hy
);
847 scm_array_handle_release (&hx
);
852 static SCM
scm_i_array_equal_p (SCM
, SCM
, SCM
);
853 SCM_DEFINE (scm_i_array_equal_p
, "array-equal?", 0, 2, 1,
854 (SCM ra0
, SCM ra1
, SCM rest
),
855 "Return @code{#t} iff all arguments are arrays with the same\n"
856 "shape, the same type, and have corresponding elements which are\n"
857 "either @code{equal?} or @code{array-equal?}. This function\n"
858 "differs from @code{equal?} in that all arguments must be arrays.")
859 #define FUNC_NAME s_scm_i_array_equal_p
861 if (SCM_UNBNDP (ra0
) || SCM_UNBNDP (ra1
))
864 while (!scm_is_null (rest
))
865 { if (scm_is_false (scm_array_equal_p (ra0
, ra1
)))
868 ra1
= scm_car (rest
);
869 rest
= scm_cdr (rest
);
871 return scm_array_equal_p (ra0
, ra1
);
877 scm_init_array_map (void)
879 #include "libguile/array-map.x"
880 scm_add_feature (s_scm_array_for_each
);