1 /* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009 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"
55 /* These tables are a kluge that will not scale well when more
56 * vectorized subrs are added. It is tempting to steal some bits from
57 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
58 * offset into a table of vectorized subrs.
61 static ra_iproc ra_rpsubrs
[] =
63 {"=", SCM_UNDEFINED
, scm_ra_eqp
},
64 {"<", SCM_UNDEFINED
, scm_ra_lessp
},
65 {"<=", SCM_UNDEFINED
, scm_ra_leqp
},
66 {">", SCM_UNDEFINED
, scm_ra_grp
},
67 {">=", SCM_UNDEFINED
, scm_ra_greqp
},
71 static ra_iproc ra_asubrs
[] =
73 {"+", SCM_UNDEFINED
, scm_ra_sum
},
74 {"-", SCM_UNDEFINED
, scm_ra_difference
},
75 {"*", SCM_UNDEFINED
, scm_ra_product
},
76 {"/", SCM_UNDEFINED
, scm_ra_divide
},
80 /* The WHAT argument for `scm_gc_malloc ()' et al. */
81 static const char indices_gc_hint
[] = "array-indices";
84 #define GVREF scm_c_generalized_vector_ref
85 #define GVSET scm_c_generalized_vector_set_x
88 cind (SCM ra
, long *ve
)
92 if (!SCM_I_ARRAYP (ra
))
94 i
= SCM_I_ARRAY_BASE (ra
);
95 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
96 i
+= (ve
[k
] - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
101 /* Checker for scm_array mapping functions:
102 return values: 4 --> shapes, increments, and bases are the same;
103 3 --> shapes and increments are the same;
104 2 --> shapes are the same;
105 1 --> ras are at least as big as ra0;
110 scm_ra_matchp (SCM ra0
, SCM ras
)
113 scm_t_array_dim dims
;
114 scm_t_array_dim
*s0
= &dims
;
116 unsigned long bas0
= 0;
118 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
120 if (scm_is_generalized_vector (ra0
))
124 s0
->ubnd
= scm_c_generalized_vector_length (ra0
) - 1;
126 else if (SCM_I_ARRAYP (ra0
))
128 ndim
= SCM_I_ARRAY_NDIM (ra0
);
129 s0
= SCM_I_ARRAY_DIMS (ra0
);
130 bas0
= SCM_I_ARRAY_BASE (ra0
);
135 while (SCM_NIMP (ras
))
139 if (scm_is_generalized_vector (ra1
))
146 length
= scm_c_generalized_vector_length (ra1
);
157 if ((0 == s0
->lbnd
) && (s0
->ubnd
== length
- 1))
161 if (s0
->lbnd
< 0 || s0
->ubnd
>= length
)
165 else if (SCM_I_ARRAYP (ra1
) && ndim
== SCM_I_ARRAY_NDIM (ra1
))
167 s1
= SCM_I_ARRAY_DIMS (ra1
);
168 if (bas0
!= SCM_I_ARRAY_BASE (ra1
))
170 for (i
= 0; i
< ndim
; i
++)
175 if (s0
[i
].inc
!= s1
[i
].inc
)
178 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
182 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
183 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
195 /* array mapper: apply cproc to each dimension of the given arrays?.
196 int (*cproc) (); procedure to call on unrolled arrays?
197 cproc (dest, source list) or
198 cproc (dest, data, source list).
199 SCM data; data to give to cproc or unbound.
200 SCM ra0; destination array.
201 SCM lra; list of source arrays.
202 const char *what; caller, for error reporting. */
204 scm_ramapc (int (*cproc
)(), SCM data
, SCM ra0
, SCM lra
, const char *what
)
211 switch (scm_ra_matchp (ra0
, lra
))
215 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
218 case 4: /* Try unrolling arrays */
219 kmax
= (SCM_I_ARRAYP (ra0
) ? SCM_I_ARRAY_NDIM (ra0
) - 1 : 0);
222 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
223 if (SCM_IMP (vra0
)) goto gencase
;
224 if (!SCM_I_ARRAYP (vra0
))
226 size_t length
= scm_c_generalized_vector_length (vra0
);
227 vra1
= scm_i_make_array (1);
228 SCM_I_ARRAY_BASE (vra1
) = 0;
229 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= 0;
230 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= length
- 1;
231 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
232 SCM_I_ARRAY_V (vra1
) = vra0
;
237 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
240 vra1
= scm_i_make_array (1);
241 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= SCM_I_ARRAY_DIMS (vra0
)->lbnd
;
242 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= SCM_I_ARRAY_DIMS (vra0
)->ubnd
;
243 if (!SCM_I_ARRAYP (ra1
))
245 SCM_I_ARRAY_BASE (vra1
) = 0;
246 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
247 SCM_I_ARRAY_V (vra1
) = ra1
;
249 else if (!SCM_I_ARRAY_CONTP (ra1
))
253 SCM_I_ARRAY_BASE (vra1
) = SCM_I_ARRAY_BASE (ra1
);
254 SCM_I_ARRAY_DIMS (vra1
)->inc
= SCM_I_ARRAY_DIMS (ra1
)[kmax
].inc
;
255 SCM_I_ARRAY_V (vra1
) = SCM_I_ARRAY_V (ra1
);
257 *plvra
= scm_cons (vra1
, SCM_EOL
);
258 plvra
= SCM_CDRLOC (*plvra
);
260 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
262 gencase
: /* Have to loop over all dimensions. */
263 vra0
= scm_i_make_array (1);
264 if (SCM_I_ARRAYP (ra0
))
266 kmax
= SCM_I_ARRAY_NDIM (ra0
) - 1;
269 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= 0;
270 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= 0;
271 SCM_I_ARRAY_DIMS (vra0
)->inc
= 1;
275 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
276 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
277 SCM_I_ARRAY_DIMS (vra0
)->inc
= SCM_I_ARRAY_DIMS (ra0
)[kmax
].inc
;
279 SCM_I_ARRAY_BASE (vra0
) = SCM_I_ARRAY_BASE (ra0
);
280 SCM_I_ARRAY_V (vra0
) = SCM_I_ARRAY_V (ra0
);
284 size_t length
= scm_c_generalized_vector_length (ra0
);
286 SCM_I_ARRAY_DIMS (vra0
)->lbnd
= 0;
287 SCM_I_ARRAY_DIMS (vra0
)->ubnd
= length
- 1;
288 SCM_I_ARRAY_DIMS (vra0
)->inc
= 1;
289 SCM_I_ARRAY_BASE (vra0
) = 0;
290 SCM_I_ARRAY_V (vra0
) = ra0
;
295 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
298 vra1
= scm_i_make_array (1);
299 SCM_I_ARRAY_DIMS (vra1
)->lbnd
= SCM_I_ARRAY_DIMS (vra0
)->lbnd
;
300 SCM_I_ARRAY_DIMS (vra1
)->ubnd
= SCM_I_ARRAY_DIMS (vra0
)->ubnd
;
301 if (SCM_I_ARRAYP (ra1
))
304 SCM_I_ARRAY_DIMS (vra1
)->inc
= SCM_I_ARRAY_DIMS (ra1
)[kmax
].inc
;
305 SCM_I_ARRAY_V (vra1
) = SCM_I_ARRAY_V (ra1
);
309 SCM_I_ARRAY_DIMS (vra1
)->inc
= 1;
310 SCM_I_ARRAY_V (vra1
) = ra1
;
312 *plvra
= scm_cons (vra1
, SCM_EOL
);
313 plvra
= SCM_CDRLOC (*plvra
);
316 vinds
= scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0
),
319 for (k
= 0; k
<= kmax
; k
++)
320 vinds
[k
] = SCM_I_ARRAY_DIMS (ra0
)[k
].lbnd
;
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
)))
335 if (vinds
[k
] < SCM_I_ARRAY_DIMS (ra0
)[k
].ubnd
)
341 vinds
[k
] = SCM_I_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
351 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
353 "Store @var{fill} in every element of @var{array}. The value returned\n"
355 #define FUNC_NAME s_scm_array_fill_x
357 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
358 return SCM_UNSPECIFIED
;
362 /* to be used as cproc in scm_ramapc to fill an array dimension with
365 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
366 #define FUNC_NAME s_scm_array_fill_x
369 unsigned long n
= SCM_I_ARRAY_DIMS (ra
)->ubnd
- SCM_I_ARRAY_DIMS (ra
)->lbnd
+ 1;
370 long inc
= SCM_I_ARRAY_DIMS (ra
)->inc
;
371 unsigned long base
= SCM_I_ARRAY_BASE (ra
);
373 ra
= SCM_I_ARRAY_V (ra
);
375 for (i
= base
; n
--; i
+= inc
)
385 racp (SCM src
, SCM dst
)
387 long n
= (SCM_I_ARRAY_DIMS (src
)->ubnd
- SCM_I_ARRAY_DIMS (src
)->lbnd
+ 1);
388 long inc_d
, inc_s
= SCM_I_ARRAY_DIMS (src
)->inc
;
389 unsigned long i_d
, i_s
= SCM_I_ARRAY_BASE (src
);
391 inc_d
= SCM_I_ARRAY_DIMS (dst
)->inc
;
392 i_d
= SCM_I_ARRAY_BASE (dst
);
393 src
= SCM_I_ARRAY_V (src
);
394 dst
= SCM_I_ARRAY_V (dst
);
396 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
397 GVSET (dst
, i_d
, GVREF (src
, i_s
));
401 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
404 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
406 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
407 "Copy every element from vector or array @var{source} to the\n"
408 "corresponding element of @var{destination}. @var{destination} must have\n"
409 "the same rank as @var{source}, and be at least as large in each\n"
410 "dimension. The order is unspecified.")
411 #define FUNC_NAME s_scm_array_copy_x
413 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
414 return SCM_UNSPECIFIED
;
418 /* Functions callable by ARRAY-MAP! */
422 scm_ra_eqp (SCM ra0
, SCM ras
)
424 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
425 scm_t_array_handle ra0_handle
;
426 scm_t_array_dim
*ra0_dims
;
430 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
431 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
432 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
433 ra1
= SCM_I_ARRAY_V (ra1
);
434 ra2
= SCM_I_ARRAY_V (ra2
);
436 scm_array_get_handle (ra0
, &ra0_handle
);
437 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
438 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
439 inc0
= ra0_dims
[0].inc
;
442 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
443 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
444 if (!scm_is_eq (GVREF (ra1
, i1
), GVREF (ra2
, i2
)))
445 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
448 scm_array_handle_release (&ra0_handle
);
452 /* opt 0 means <, nonzero means >= */
455 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
457 scm_t_array_handle ra0_handle
;
458 scm_t_array_dim
*ra0_dims
;
462 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
463 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
464 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
465 ra1
= SCM_I_ARRAY_V (ra1
);
466 ra2
= SCM_I_ARRAY_V (ra2
);
468 scm_array_get_handle (ra0
, &ra0_handle
);
469 ra0_dims
= scm_array_handle_dims (&ra0_handle
);
470 n
= ra0_dims
[0].ubnd
- ra0_dims
[0].lbnd
+ 1;
471 inc0
= ra0_dims
[0].inc
;
474 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
475 if (scm_is_true (scm_array_handle_ref (&ra0_handle
, i0
)))
477 scm_is_true (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))) :
478 scm_is_false (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))))
479 scm_array_handle_set (&ra0_handle
, i0
, SCM_BOOL_F
);
482 scm_array_handle_release (&ra0_handle
);
489 scm_ra_lessp (SCM ra0
, SCM ras
)
491 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
496 scm_ra_leqp (SCM ra0
, SCM ras
)
498 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
503 scm_ra_grp (SCM ra0
, SCM ras
)
505 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
510 scm_ra_greqp (SCM ra0
, SCM ras
)
512 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
517 scm_ra_sum (SCM ra0
, SCM ras
)
519 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
520 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
521 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
522 ra0
= SCM_I_ARRAY_V (ra0
);
523 if (!scm_is_null(ras
))
525 SCM ra1
= SCM_CAR (ras
);
526 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
527 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
528 ra1
= SCM_I_ARRAY_V (ra1
);
529 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
533 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
534 GVSET (ra0
, i0
, scm_sum (GVREF(ra0
, i0
), GVREF(ra1
, i1
)));
545 scm_ra_difference (SCM ra0
, SCM ras
)
547 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
548 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
549 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
550 ra0
= SCM_I_ARRAY_V (ra0
);
551 if (scm_is_null (ras
))
553 switch (SCM_TYP7 (ra0
))
557 for (; n
-- > 0; i0
+= inc0
)
558 GVSET (ra0
, i0
, scm_difference (GVREF(ra0
, i0
), SCM_UNDEFINED
));
565 SCM ra1
= SCM_CAR (ras
);
566 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
567 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
568 ra1
= SCM_I_ARRAY_V (ra1
);
569 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
573 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
574 GVSET (ra0
, i0
, scm_difference (GVREF (ra0
, i0
),
586 scm_ra_product (SCM ra0
, SCM ras
)
588 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
589 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
590 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
591 ra0
= SCM_I_ARRAY_V (ra0
);
592 if (!scm_is_null (ras
))
594 SCM ra1
= SCM_CAR (ras
);
595 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
596 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
597 ra1
= SCM_I_ARRAY_V (ra1
);
598 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
602 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
603 GVSET (ra0
, i0
, scm_product (GVREF (ra0
, i0
),
613 scm_ra_divide (SCM ra0
, SCM ras
)
615 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
616 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
617 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
618 ra0
= SCM_I_ARRAY_V (ra0
);
619 if (scm_is_null (ras
))
621 switch (SCM_TYP7 (ra0
))
625 for (; n
-- > 0; i0
+= inc0
)
626 GVSET (ra0
, i0
, scm_divide (GVREF (ra0
, i0
), SCM_UNDEFINED
));
633 SCM ra1
= SCM_CAR (ras
);
634 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
635 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
636 ra1
= SCM_I_ARRAY_V (ra1
);
637 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
641 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
643 SCM res
= scm_divide (GVREF (ra0
, i0
),
645 GVSET (ra0
, i0
, res
);
656 scm_array_identity (SCM dst
, SCM src
)
658 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
664 ramap (SCM ra0
, SCM proc
, SCM ras
)
666 long i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
667 long inc
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
668 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
;
669 long base
= SCM_I_ARRAY_BASE (ra0
) - i
* inc
;
670 ra0
= SCM_I_ARRAY_V (ra0
);
671 if (scm_is_null (ras
))
673 GVSET (ra0
, i
*inc
+base
, scm_call_0 (proc
));
676 SCM ra1
= SCM_CAR (ras
);
678 unsigned long k
, i1
= SCM_I_ARRAY_BASE (ra1
);
679 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
680 ra1
= SCM_I_ARRAY_V (ra1
);
682 if (scm_is_null(ras
))
685 ras
= scm_vector (ras
);
687 for (; i
<= n
; i
++, i1
+= inc1
)
690 for (k
= scm_c_vector_length (ras
); k
--;)
691 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
692 args
= scm_cons (GVREF (ra1
, i1
), args
);
693 GVSET (ra0
, i
*inc
+base
, scm_apply_0 (proc
, args
));
701 ramap_dsubr (SCM ra0
, SCM proc
, SCM ras
)
703 SCM ra1
= SCM_CAR (ras
);
704 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
), i1
= SCM_I_ARRAY_BASE (ra1
);
705 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
706 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra1
)->lbnd
+ 1;
707 ra0
= SCM_I_ARRAY_V (ra0
);
708 ra1
= SCM_I_ARRAY_V (ra1
);
709 switch (SCM_TYP7 (ra0
))
712 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
713 GVSET (ra0
, i0
, scm_call_1 (proc
, GVREF (ra1
, i1
)));
722 ramap_rp (SCM ra0
, SCM proc
, SCM ras
)
724 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
725 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
726 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
), i1
= SCM_I_ARRAY_BASE (ra1
), i2
= SCM_I_ARRAY_BASE (ra2
);
727 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
728 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
729 long inc2
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
730 ra0
= SCM_I_ARRAY_V (ra0
);
731 ra1
= SCM_I_ARRAY_V (ra1
);
732 ra2
= SCM_I_ARRAY_V (ra2
);
734 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
735 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
736 if (scm_is_false (SCM_SUBRF (proc
) (GVREF (ra1
, i1
), GVREF (ra2
, i2
))))
737 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
745 ramap_1 (SCM ra0
, SCM proc
, SCM ras
)
747 SCM ra1
= SCM_CAR (ras
);
748 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
749 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
), i1
= SCM_I_ARRAY_BASE (ra1
);
750 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
751 ra0
= SCM_I_ARRAY_V (ra0
);
752 ra1
= SCM_I_ARRAY_V (ra1
);
753 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
754 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
755 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
)));
757 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
758 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
)));
765 ramap_2o (SCM ra0
, SCM proc
, SCM ras
)
767 SCM ra1
= SCM_CAR (ras
);
768 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
769 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
), i1
= SCM_I_ARRAY_BASE (ra1
);
770 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
771 ra0
= SCM_I_ARRAY_V (ra0
);
772 ra1
= SCM_I_ARRAY_V (ra1
);
774 if (scm_is_null (ras
))
776 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
777 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
), SCM_UNDEFINED
));
781 SCM ra2
= SCM_CAR (ras
);
782 unsigned long i2
= SCM_I_ARRAY_BASE (ra2
);
783 long inc2
= SCM_I_ARRAY_DIMS (ra2
)->inc
;
784 ra2
= SCM_I_ARRAY_V (ra2
);
785 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
786 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
), GVREF (ra2
, i2
)));
794 ramap_a (SCM ra0
, SCM proc
, SCM ras
)
796 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
797 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
798 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
799 ra0
= SCM_I_ARRAY_V (ra0
);
800 if (scm_is_null (ras
))
801 for (; n
-- > 0; i0
+= inc0
)
802 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra0
, i0
), SCM_UNDEFINED
));
805 SCM ra1
= SCM_CAR (ras
);
806 unsigned long i1
= SCM_I_ARRAY_BASE (ra1
);
807 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
808 ra1
= SCM_I_ARRAY_V (ra1
);
809 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
810 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra0
, i0
), GVREF (ra1
, i1
)));
816 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
818 SCM_SYMBOL (sym_b
, "b");
820 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
821 (SCM ra0
, SCM proc
, SCM lra
),
822 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
823 "@var{array1}, @dots{} must have the same number of dimensions as\n"
824 "@var{array0} and have a range for each index which includes the range\n"
825 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
826 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
827 "as the corresponding element in @var{array0}. The value returned is\n"
828 "unspecified. The order of application is unspecified.")
829 #define FUNC_NAME s_scm_array_map_x
831 SCM_VALIDATE_PROC (2, proc
);
832 SCM_VALIDATE_REST_ARGUMENT (lra
);
834 switch (SCM_TYP7 (proc
))
838 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
839 return SCM_UNSPECIFIED
;
841 if (! scm_is_pair (lra
))
842 SCM_WRONG_NUM_ARGS (); /* need 1 source */
843 scm_ramapc (ramap_1
, proc
, ra0
, lra
, FUNC_NAME
);
844 return SCM_UNSPECIFIED
;
846 if (! (scm_is_pair (lra
) && scm_is_pair (SCM_CDR (lra
))))
847 SCM_WRONG_NUM_ARGS (); /* need 2 sources */
849 case scm_tc7_subr_2o
:
850 if (! scm_is_pair (lra
))
851 SCM_WRONG_NUM_ARGS (); /* need 1 source */
853 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
854 return SCM_UNSPECIFIED
;
856 if (! scm_is_pair (lra
))
857 SCM_WRONG_NUM_ARGS (); /* need 1 source */
858 scm_ramapc (ramap_dsubr
, proc
, ra0
, lra
, FUNC_NAME
);
859 return SCM_UNSPECIFIED
;
863 if (!scm_is_typed_array (ra0
, sym_b
))
865 scm_array_fill_x (ra0
, SCM_BOOL_T
);
866 for (p
= ra_rpsubrs
; p
->name
; p
++)
867 if (scm_is_eq (proc
, p
->sproc
))
869 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
871 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
874 return SCM_UNSPECIFIED
;
876 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
878 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, FUNC_NAME
);
881 return SCM_UNSPECIFIED
;
884 if (scm_is_null (lra
))
886 SCM fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
887 scm_array_fill_x (ra0
, fill
);
891 SCM tail
, ra1
= SCM_CAR (lra
);
892 SCM v0
= (SCM_I_ARRAYP (ra0
) ? SCM_I_ARRAY_V (ra0
) : ra0
);
894 /* Check to see if order might matter.
895 This might be an argument for a separate
897 if (scm_is_eq (v0
, ra1
)
898 || (SCM_I_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_I_ARRAY_V (ra1
))))
899 if (!scm_is_eq (ra0
, ra1
)
900 || (SCM_I_ARRAYP(ra0
) && !SCM_I_ARRAY_CONTP(ra0
)))
902 for (tail
= SCM_CDR (lra
); !scm_is_null (tail
); tail
= SCM_CDR (tail
))
904 ra1
= SCM_CAR (tail
);
905 if (scm_is_eq (v0
, ra1
)
906 || (SCM_I_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_I_ARRAY_V (ra1
))))
909 for (p
= ra_asubrs
; p
->name
; p
++)
910 if (scm_is_eq (proc
, p
->sproc
))
912 if (!scm_is_eq (ra0
, SCM_CAR (lra
)))
913 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), FUNC_NAME
);
917 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
918 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
919 return SCM_UNSPECIFIED
;
923 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
926 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
927 scm_ramapc (ramap_a
, proc
, ra0
, lra
, FUNC_NAME
);
929 return SCM_UNSPECIFIED
;
936 rafe (SCM ra0
, SCM proc
, SCM ras
)
938 long i
= SCM_I_ARRAY_DIMS (ra0
)->lbnd
;
939 unsigned long i0
= SCM_I_ARRAY_BASE (ra0
);
940 long inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
941 long n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
;
942 ra0
= SCM_I_ARRAY_V (ra0
);
943 if (scm_is_null (ras
))
944 for (; i
<= n
; i
++, i0
+= inc0
)
945 scm_call_1 (proc
, GVREF (ra0
, i0
));
948 SCM ra1
= SCM_CAR (ras
);
950 unsigned long k
, i1
= SCM_I_ARRAY_BASE (ra1
);
951 long inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
952 ra1
= SCM_I_ARRAY_V (ra1
);
954 if (scm_is_null(ras
))
957 ras
= scm_vector (ras
);
958 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
961 for (k
= scm_c_vector_length (ras
); k
--;)
962 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
963 args
= scm_cons2 (GVREF (ra0
, i0
), GVREF (ra1
, i1
), args
);
964 scm_apply_0 (proc
, args
);
971 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
972 (SCM proc
, SCM ra0
, SCM lra
),
973 "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
974 "in row-major order. The value returned is unspecified.")
975 #define FUNC_NAME s_scm_array_for_each
977 SCM_VALIDATE_PROC (1, proc
);
978 SCM_VALIDATE_REST_ARGUMENT (lra
);
979 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
980 return SCM_UNSPECIFIED
;
984 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
986 "Apply @var{proc} to the indices of each element of @var{array} in\n"
987 "turn, storing the result in the corresponding element. The value\n"
988 "returned and the order of application are unspecified.\n\n"
989 "One can implement @var{array-indexes} as\n"
991 "(define (array-indexes array)\n"
992 " (let ((ra (apply make-array #f (array-shape array))))\n"
993 " (array-index-map! ra (lambda x x))\n"
998 "(define (apl:index-generator n)\n"
999 " (let ((v (make-uniform-vector n 1)))\n"
1000 " (array-index-map! v (lambda (i) i))\n"
1003 #define FUNC_NAME s_scm_array_index_map_x
1006 SCM_VALIDATE_PROC (2, proc
);
1008 if (SCM_I_ARRAYP (ra
))
1011 int j
, k
, kmax
= SCM_I_ARRAY_NDIM (ra
) - 1;
1015 return scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
1017 vinds
= scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra
),
1020 for (k
= 0; k
<= kmax
; k
++)
1021 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1027 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1028 i
= cind (ra
, vinds
);
1029 for (; vinds
[k
] <= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1031 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1032 args
= scm_cons (scm_from_long (vinds
[j
]), args
);
1033 GVSET (SCM_I_ARRAY_V (ra
), i
, scm_apply_0 (proc
, args
));
1034 i
+= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
1039 if (vinds
[k
] < SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
)
1045 vinds
[k
] = SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1050 return SCM_UNSPECIFIED
;
1052 else if (scm_is_generalized_vector (ra
))
1054 size_t length
= scm_c_generalized_vector_length (ra
);
1055 for (i
= 0; i
< length
; i
++)
1056 GVSET (ra
, i
, scm_call_1 (proc
, scm_from_ulong (i
)));
1057 return SCM_UNSPECIFIED
;
1060 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1066 raeql_1 (SCM ra0
, SCM as_equal
, SCM ra1
)
1068 unsigned long i0
= 0, i1
= 0;
1069 long inc0
= 1, inc1
= 1;
1071 ra1
= SCM_CAR (ra1
);
1072 if (SCM_I_ARRAYP(ra0
))
1074 n
= SCM_I_ARRAY_DIMS (ra0
)->ubnd
- SCM_I_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1075 i0
= SCM_I_ARRAY_BASE (ra0
);
1076 inc0
= SCM_I_ARRAY_DIMS (ra0
)->inc
;
1077 ra0
= SCM_I_ARRAY_V (ra0
);
1080 n
= scm_c_generalized_vector_length (ra0
);
1082 if (SCM_I_ARRAYP (ra1
))
1084 i1
= SCM_I_ARRAY_BASE (ra1
);
1085 inc1
= SCM_I_ARRAY_DIMS (ra1
)->inc
;
1086 ra1
= SCM_I_ARRAY_V (ra1
);
1089 if (scm_is_generalized_vector (ra0
))
1091 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1093 if (scm_is_false (as_equal
))
1095 if (scm_is_false (scm_array_equal_p (GVREF (ra0
, i0
), GVREF (ra1
, i1
))))
1098 else if (scm_is_false (scm_equal_p (GVREF (ra0
, i0
), GVREF (ra1
, i1
))))
1110 raeql (SCM ra0
, SCM as_equal
, SCM ra1
)
1112 SCM v0
= ra0
, v1
= ra1
;
1113 scm_t_array_dim dim0
, dim1
;
1114 scm_t_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1115 unsigned long bas0
= 0, bas1
= 0;
1116 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1117 if (SCM_I_ARRAYP (ra0
))
1119 ndim
= SCM_I_ARRAY_NDIM (ra0
);
1120 s0
= SCM_I_ARRAY_DIMS (ra0
);
1121 bas0
= SCM_I_ARRAY_BASE (ra0
);
1122 v0
= SCM_I_ARRAY_V (ra0
);
1128 s0
->ubnd
= scm_c_generalized_vector_length (v0
) - 1;
1131 if (SCM_I_ARRAYP (ra1
))
1133 if (ndim
!= SCM_I_ARRAY_NDIM (ra1
))
1135 s1
= SCM_I_ARRAY_DIMS (ra1
);
1136 bas1
= SCM_I_ARRAY_BASE (ra1
);
1137 v1
= SCM_I_ARRAY_V (ra1
);
1142 Huh ? Schizophrenic return type. --hwn
1148 s1
->ubnd
= scm_c_generalized_vector_length (v1
) - 1;
1151 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
1153 for (k
= ndim
; k
--;)
1155 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
1159 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
1160 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
1163 if (unroll
&& bas0
== bas1
&& scm_is_eq (v0
, v1
))
1165 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
1170 scm_raequal (SCM ra0
, SCM ra1
)
1172 return scm_from_bool(raeql (ra0
, SCM_BOOL_T
, ra1
));
1176 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1177 SCM_DEFINE1 (scm_array_equal_p
, "array-equal?", scm_tc7_rpsubr
,
1179 "Return @code{#t} iff all arguments are arrays with the same\n"
1180 "shape, the same type, and have corresponding elements which are\n"
1181 "either @code{equal?} or @code{array-equal?}. This function\n"
1182 "differs from @code{equal?} in that a one dimensional shared\n"
1183 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1184 "vector or uniform vector.")
1185 #define FUNC_NAME s_scm_array_equal_p
1191 static char s_array_equal_p
[] = "array-equal?";
1195 scm_array_equal_p (SCM ra0
, SCM ra1
)
1197 if (SCM_I_ARRAYP (ra0
) || SCM_I_ARRAYP (ra1
))
1198 return scm_from_bool(raeql (ra0
, SCM_BOOL_F
, ra1
));
1199 return scm_equal_p (ra0
, ra1
);
1204 init_raprocs (ra_iproc
*subra
)
1206 for (; subra
->name
; subra
++)
1208 SCM sym
= scm_from_locale_symbol (subra
->name
);
1210 scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_F
);
1211 if (var
!= SCM_BOOL_F
)
1212 subra
->sproc
= SCM_VARIABLE_REF (var
);
1214 subra
->sproc
= SCM_BOOL_F
;
1220 scm_init_array_map (void)
1222 init_raprocs (ra_rpsubrs
);
1223 init_raprocs (ra_asubrs
);
1224 scm_c_define_subr (s_array_equal_p
, scm_tc7_rpsubr
, scm_array_equal_p
);
1225 scm_smobs
[SCM_TC2SMOBNUM (scm_i_tc16_array
)].equalp
= scm_raequal
;
1226 #include "libguile/array-map.x"
1227 scm_add_feature (s_scm_array_for_each
);