ef6707db799987060a6a00f7a204881b0c321d02
1 /* Copyright (C) 1996,1998,2000,2001,2004 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 Someone should rename this to arraymap.c; that would reflect the
28 #include "libguile/_scm.h"
29 #include "libguile/strings.h"
30 #include "libguile/unif.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/srfi-4.h"
39 #include "libguile/dynwind.h"
41 #include "libguile/validate.h"
42 #include "libguile/ramap.h"
53 /* These tables are a kluge that will not scale well when more
54 * vectorized subrs are added. It is tempting to steal some bits from
55 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
56 * offset into a table of vectorized subrs.
59 static ra_iproc ra_rpsubrs
[] =
61 {"=", SCM_UNDEFINED
, scm_ra_eqp
},
62 {"<", SCM_UNDEFINED
, scm_ra_lessp
},
63 {"<=", SCM_UNDEFINED
, scm_ra_leqp
},
64 {">", SCM_UNDEFINED
, scm_ra_grp
},
65 {">=", SCM_UNDEFINED
, scm_ra_greqp
},
69 static ra_iproc ra_asubrs
[] =
71 {"+", SCM_UNDEFINED
, scm_ra_sum
},
72 {"-", SCM_UNDEFINED
, scm_ra_difference
},
73 {"*", SCM_UNDEFINED
, scm_ra_product
},
74 {"/", SCM_UNDEFINED
, scm_ra_divide
},
80 /* Fast, recycling scm_vector ref */
81 #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
83 /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
85 /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
86 elements of scm_vector operands are not aliased */
88 #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
90 #define IVDEP(test, line) line
95 /* inds must be a uvect or ivect, no check. */
100 Yes, this is really ugly, but it prevents multiple code
102 #define BINARY_ELTS_CODE(OPERATOR, type) \
103 do { type *v0 = (type*)SCM_VELTS (ra0);\
104 type *v1 = (type*)SCM_VELTS (ra1);\
106 for (; n-- > 0; i0 += inc0, i1 += inc1) \
107 v0[i0] OPERATOR v1[i1];) \
110 /* This macro is used for all but binary division and
111 multiplication of complex numbers -- see the expanded
112 version in the functions later in this file */
113 #define BINARY_PAIR_ELTS_CODE(OPERATOR, type) \
114 do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
115 type (*v1)[2] = (type (*)[2]) SCM_VELTS (ra1);\
117 for (; n-- > 0; i0 += inc0, i1 += inc1) {\
118 v0[i0][0] OPERATOR v1[i1][0]; \
119 v0[i0][1] OPERATOR v1[i1][1]; \
123 #define UNARY_ELTS_CODE(OPERATOR, type) \
124 do { type *v0 = (type *) SCM_VELTS (ra0);\
125 for (; n-- > 0; i0 += inc0) \
126 v0[i0] OPERATOR v0[i0];\
130 /* This macro is used for all but unary divison
131 of complex numbers -- see the expanded version in the
132 function later in this file. */
133 #define UNARY_PAIR_ELTS_CODE(OPERATOR, type) \
134 do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
135 for (; n-- > 0; i0 += inc0) {\
136 v0[i0][0] OPERATOR v0[i0][0];\
137 v0[i0][1] OPERATOR v0[i0][1];\
143 cind (SCM ra
, long *ve
)
147 if (!SCM_ARRAYP (ra
))
149 i
= SCM_ARRAY_BASE (ra
);
150 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
151 i
+= (ve
[k
] - SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_ARRAY_DIMS (ra
)[k
].inc
;
156 /* Checker for scm_array mapping functions:
157 return values: 4 --> shapes, increments, and bases are the same;
158 3 --> shapes and increments are the same;
159 2 --> shapes are the same;
160 1 --> ras are at least as big as ra0;
165 scm_ra_matchp (SCM ra0
, SCM ras
)
168 scm_t_array_dim dims
;
169 scm_t_array_dim
*s0
= &dims
;
171 unsigned long bas0
= 0;
173 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
175 if (scm_is_generalized_vector (ra0
))
179 s0
->ubnd
= scm_c_generalized_vector_length (ra0
) - 1;
181 else if (SCM_ARRAYP (ra0
))
183 ndim
= SCM_ARRAY_NDIM (ra0
);
184 s0
= SCM_ARRAY_DIMS (ra0
);
185 bas0
= SCM_ARRAY_BASE (ra0
);
190 while (SCM_NIMP (ras
))
194 if (scm_is_generalized_vector (ra1
))
201 length
= scm_c_generalized_vector_length (ra1
);
212 if ((0 == s0
->lbnd
) && (s0
->ubnd
== length
- 1))
216 if (s0
->lbnd
< 0 || s0
->ubnd
>= length
)
220 else if (SCM_ARRAYP (ra1
) && ndim
== SCM_ARRAY_NDIM (ra1
))
222 s1
= SCM_ARRAY_DIMS (ra1
);
223 if (bas0
!= SCM_ARRAY_BASE (ra1
))
225 for (i
= 0; i
< ndim
; i
++)
230 if (s0
[i
].inc
!= s1
[i
].inc
)
233 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
237 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
238 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
250 /* array mapper: apply cproc to each dimension of the given arrays?.
251 int (*cproc) (); procedure to call on unrolled arrays?
252 cproc (dest, source list) or
253 cproc (dest, data, source list).
254 SCM data; data to give to cproc or unbound.
255 SCM ra0; destination array.
256 SCM lra; list of source arrays.
257 const char *what; caller, for error reporting. */
259 scm_ramapc (int (*cproc
)(), SCM data
, SCM ra0
, SCM lra
, const char *what
)
266 switch (scm_ra_matchp (ra0
, lra
))
270 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
273 case 4: /* Try unrolling arrays */
274 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
277 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
278 if (SCM_IMP (vra0
)) goto gencase
;
279 if (!SCM_ARRAYP (vra0
))
281 size_t length
= scm_c_generalized_vector_length (vra0
);
282 vra1
= scm_make_ra (1);
283 SCM_ARRAY_BASE (vra1
) = 0;
284 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
285 SCM_ARRAY_DIMS (vra1
)->ubnd
= length
- 1;
286 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
287 SCM_ARRAY_V (vra1
) = vra0
;
292 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
295 vra1
= scm_make_ra (1);
296 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
297 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
298 if (!SCM_ARRAYP (ra1
))
300 SCM_ARRAY_BASE (vra1
) = 0;
301 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
302 SCM_ARRAY_V (vra1
) = ra1
;
304 else if (!SCM_ARRAY_CONTP (ra1
))
308 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
309 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
310 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
312 *plvra
= scm_cons (vra1
, SCM_EOL
);
313 plvra
= SCM_CDRLOC (*plvra
);
315 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
317 gencase
: /* Have to loop over all dimensions. */
318 vra0
= scm_make_ra (1);
319 if (SCM_ARRAYP (ra0
))
321 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
324 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
325 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
326 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
330 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
331 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
332 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
334 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
335 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
339 size_t length
= scm_c_generalized_vector_length (ra0
);
341 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
342 SCM_ARRAY_DIMS (vra0
)->ubnd
= length
- 1;
343 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
344 SCM_ARRAY_BASE (vra0
) = 0;
345 SCM_ARRAY_V (vra0
) = ra0
;
350 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
353 vra1
= scm_make_ra (1);
354 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
355 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
356 if (SCM_ARRAYP (ra1
))
359 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
360 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
364 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
365 SCM_ARRAY_V (vra1
) = ra1
;
367 *plvra
= scm_cons (vra1
, SCM_EOL
);
368 plvra
= SCM_CDRLOC (*plvra
);
373 vinds
= scm_malloc (sizeof(long) * SCM_ARRAY_NDIM (ra0
));
374 scm_frame_free (vinds
);
376 for (k
= 0; k
<= kmax
; k
++)
377 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
384 SCM_ARRAY_BASE (vra0
) = cind (ra0
, vinds
);
385 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
386 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), vinds
);
387 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
392 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
398 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
409 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
411 "Store @var{fill} in every element of @var{array}. The value returned\n"
413 #define FUNC_NAME s_scm_array_fill_x
415 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
416 return SCM_UNSPECIFIED
;
420 /* to be used as cproc in scm_ramapc to fill an array dimension with
423 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
424 #define FUNC_NAME s_scm_array_fill_x
427 unsigned long n
= SCM_ARRAY_DIMS (ra
)->ubnd
- SCM_ARRAY_DIMS (ra
)->lbnd
+ 1;
428 long inc
= SCM_ARRAY_DIMS (ra
)->inc
;
429 unsigned long base
= SCM_ARRAY_BASE (ra
);
431 ra
= SCM_ARRAY_V (ra
);
433 for (i
= base
; n
--; i
+= inc
)
434 scm_c_generalized_vector_set_x (ra
, i
, fill
);
443 racp (SCM src
, SCM dst
)
445 long n
= (SCM_ARRAY_DIMS (src
)->ubnd
- SCM_ARRAY_DIMS (src
)->lbnd
+ 1);
446 long inc_d
, inc_s
= SCM_ARRAY_DIMS (src
)->inc
;
447 unsigned long i_d
, i_s
= SCM_ARRAY_BASE (src
);
449 inc_d
= SCM_ARRAY_DIMS (dst
)->inc
;
450 i_d
= SCM_ARRAY_BASE (dst
);
451 src
= SCM_ARRAY_V (src
);
452 dst
= SCM_ARRAY_V (dst
);
454 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
455 scm_c_generalized_vector_set_x (dst
, i_d
,
456 scm_cvref (src
, i_s
, SCM_UNDEFINED
));
460 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
463 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
465 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
466 "Copy every element from vector or array @var{source} to the\n"
467 "corresponding element of @var{destination}. @var{destination} must have\n"
468 "the same rank as @var{source}, and be at least as large in each\n"
469 "dimension. The order is unspecified.")
470 #define FUNC_NAME s_scm_array_copy_x
472 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
473 return SCM_UNSPECIFIED
;
477 /* Functions callable by ARRAY-MAP! */
481 scm_ra_eqp (SCM ra0
, SCM ras
)
483 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
484 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
485 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
486 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
487 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
488 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
489 ra0
= SCM_ARRAY_V (ra0
);
490 ra1
= SCM_ARRAY_V (ra1
);
491 ra2
= SCM_ARRAY_V (ra2
);
494 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
495 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
496 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
497 if (!scm_is_eq (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)))
498 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
504 /* opt 0 means <, nonzero means >= */
507 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
509 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
510 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
511 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
512 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
513 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
514 ra0
= SCM_ARRAY_V (ra0
);
515 ra1
= SCM_ARRAY_V (ra1
);
516 ra2
= SCM_ARRAY_V (ra2
);
519 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
520 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
521 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
523 scm_is_true (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))) :
524 scm_is_false (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
525 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
534 scm_ra_lessp (SCM ra0
, SCM ras
)
536 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
541 scm_ra_leqp (SCM ra0
, SCM ras
)
543 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
548 scm_ra_grp (SCM ra0
, SCM ras
)
550 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
555 scm_ra_greqp (SCM ra0
, SCM ras
)
557 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
562 scm_ra_sum (SCM ra0
, SCM ras
)
564 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
565 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
566 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
567 ra0
= SCM_ARRAY_V (ra0
);
568 if (!scm_is_null(ras
))
570 SCM ra1
= SCM_CAR (ras
);
571 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
572 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
573 ra1
= SCM_ARRAY_V (ra1
);
574 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
578 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
579 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
580 scm_c_generalized_vector_set_x (ra0
, i0
,
581 scm_sum (RVREF(ra0
, i0
, e0
),
582 RVREF(ra1
, i1
, e1
)));
593 scm_ra_difference (SCM ra0
, SCM ras
)
595 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
596 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
597 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
598 ra0
= SCM_ARRAY_V (ra0
);
599 if (scm_is_null (ras
))
601 switch (SCM_TYP7 (ra0
))
605 SCM e0
= SCM_UNDEFINED
;
606 for (; n
-- > 0; i0
+= inc0
)
608 SCM res
= scm_difference (RVREF(ra0
, i0
, e0
), SCM_UNDEFINED
);
609 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
617 SCM ra1
= SCM_CAR (ras
);
618 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
619 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
620 ra1
= SCM_ARRAY_V (ra1
);
621 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
625 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
626 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
628 SCM res
= scm_difference (RVREF (ra0
, i0
, e0
),
629 RVREF (ra1
, i1
, e1
));
630 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
642 scm_ra_product (SCM ra0
, SCM ras
)
644 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
645 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
646 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
647 ra0
= SCM_ARRAY_V (ra0
);
648 if (!scm_is_null (ras
))
650 SCM ra1
= SCM_CAR (ras
);
651 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
652 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
653 ra1
= SCM_ARRAY_V (ra1
);
654 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
658 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
659 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
661 SCM res
= scm_product (RVREF (ra0
, i0
, e0
),
662 RVREF (ra1
, i1
, e1
));
663 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
674 scm_ra_divide (SCM ra0
, SCM ras
)
676 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
677 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
678 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
679 ra0
= SCM_ARRAY_V (ra0
);
680 if (scm_is_null (ras
))
682 switch (SCM_TYP7 (ra0
))
686 SCM e0
= SCM_UNDEFINED
;
687 for (; n
-- > 0; i0
+= inc0
)
689 SCM res
= scm_divide (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
);
690 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
698 SCM ra1
= SCM_CAR (ras
);
699 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
700 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
701 ra1
= SCM_ARRAY_V (ra1
);
702 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
706 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
707 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
709 SCM res
= scm_divide (RVREF (ra0
, i0
, e0
),
710 RVREF (ra1
, i1
, e1
));
711 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
722 scm_array_identity (SCM dst
, SCM src
)
724 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
730 ramap (SCM ra0
, SCM proc
, SCM ras
)
732 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
733 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
734 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
735 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
736 ra0
= SCM_ARRAY_V (ra0
);
737 if (scm_is_null (ras
))
739 scm_c_generalized_vector_set_x (ra0
, i
*inc
+base
, scm_call_0 (proc
));
742 SCM ra1
= SCM_CAR (ras
);
744 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
745 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
746 ra1
= SCM_ARRAY_V (ra1
);
748 if (scm_is_null(ras
))
751 ras
= scm_vector (ras
);
753 for (; i
<= n
; i
++, i1
+= inc1
)
756 for (k
= scm_c_vector_length (ras
); k
--;)
757 args
= scm_cons (scm_c_generalized_vector_ref (scm_c_vector_ref (ras
, k
), i
), args
);
758 args
= scm_cons (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
759 scm_c_generalized_vector_set_x (ra0
, i
*inc
+base
,
760 scm_apply_0 (proc
, args
));
768 ramap_dsubr (SCM ra0
, SCM proc
, SCM ras
)
770 SCM ra1
= SCM_CAR (ras
);
771 SCM e1
= SCM_UNDEFINED
;
772 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
773 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
774 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
775 ra0
= SCM_ARRAY_V (ra0
);
776 ra1
= SCM_ARRAY_V (ra1
);
777 switch (SCM_TYP7 (ra0
))
780 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
781 scm_c_generalized_vector_set_x (ra0
, i0
,
782 scm_call_1 (proc
, RVREF (ra1
, i1
, e1
)));
791 ramap_rp (SCM ra0
, SCM proc
, SCM ras
)
793 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
794 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
795 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
796 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
797 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
798 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
799 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
800 ra0
= SCM_ARRAY_V (ra0
);
801 ra1
= SCM_ARRAY_V (ra1
);
802 ra2
= SCM_ARRAY_V (ra2
);
804 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
805 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
806 if (scm_is_false (SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
807 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
815 ramap_1 (SCM ra0
, SCM proc
, SCM ras
)
817 SCM ra1
= SCM_CAR (ras
);
818 SCM e1
= SCM_UNDEFINED
;
819 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
820 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
821 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
822 ra0
= SCM_ARRAY_V (ra0
);
823 ra1
= SCM_ARRAY_V (ra1
);
824 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
825 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
827 SCM res
= SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
));
828 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
831 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
833 SCM res
= SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
));
834 scm_c_generalized_vector_set_x (ra0
, i0
, res
);
842 ramap_2o (SCM ra0
, SCM proc
, SCM ras
)
844 SCM ra1
= SCM_CAR (ras
);
845 SCM e1
= SCM_UNDEFINED
;
846 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
847 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
848 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
849 ra0
= SCM_ARRAY_V (ra0
);
850 ra1
= SCM_ARRAY_V (ra1
);
852 if (scm_is_null (ras
))
854 if (scm_tc7_vector
== SCM_TYP7 (ra0
)
855 || scm_tc7_wvect
== SCM_TYP7 (ra0
))
857 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
858 scm_c_generalized_vector_set_x (ra0
, i0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), SCM_UNDEFINED
));
860 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
861 scm_c_generalized_vector_set_x (ra0
, i0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), SCM_UNDEFINED
));
865 SCM ra2
= SCM_CAR (ras
);
866 SCM e2
= SCM_UNDEFINED
;
867 unsigned long i2
= SCM_ARRAY_BASE (ra2
);
868 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
869 ra2
= SCM_ARRAY_V (ra2
);
870 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
871 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
872 scm_c_generalized_vector_set_x (ra0
, i0
,
873 SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), scm_cvref (ra2
, i2
, SCM_UNDEFINED
)));
875 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
876 scm_c_generalized_vector_set_x (ra0
, i0
,
877 SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)));
885 ramap_a (SCM ra0
, SCM proc
, SCM ras
)
887 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
888 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
889 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
890 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
891 ra0
= SCM_ARRAY_V (ra0
);
892 if (scm_is_null (ras
))
893 for (; n
-- > 0; i0
+= inc0
)
894 scm_c_generalized_vector_set_x (ra0
, i0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
));
897 SCM ra1
= SCM_CAR (ras
);
898 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
899 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
900 ra1
= SCM_ARRAY_V (ra1
);
901 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
902 scm_c_generalized_vector_set_x (ra0
, i0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)));
908 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
911 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
912 (SCM ra0
, SCM proc
, SCM lra
),
913 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
914 "@var{array1}, @dots{} must have the same number of dimensions as\n"
915 "@var{array0} and have a range for each index which includes the range\n"
916 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
917 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
918 "as the corresponding element in @var{array0}. The value returned is\n"
919 "unspecified. The order of application is unspecified.")
920 #define FUNC_NAME s_scm_array_map_x
922 SCM_VALIDATE_PROC (2, proc
);
923 SCM_VALIDATE_REST_ARGUMENT (lra
);
924 /* This is done as a test on lra, rather than an extra mandatory parameter
925 eval could check, so that the prototype for scm_array_map_x stays as it
926 was in the past. scm_array_map_x isn't actually documented, but did
927 get a mention in the NEWS file, so is best left alone. */
928 if (scm_is_null (lra
))
929 SCM_WRONG_NUM_ARGS ();
930 switch (SCM_TYP7 (proc
))
934 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
935 return SCM_UNSPECIFIED
;
937 scm_ramapc (ramap_1
, proc
, ra0
, lra
, FUNC_NAME
);
938 return SCM_UNSPECIFIED
;
940 case scm_tc7_subr_2o
:
941 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
942 return SCM_UNSPECIFIED
;
944 scm_ramapc (ramap_dsubr
, proc
, ra0
, lra
, FUNC_NAME
);
945 return SCM_UNSPECIFIED
;
949 if (scm_is_false (scm_array_p (ra0
, SCM_BOOL_T
)))
951 scm_array_fill_x (ra0
, SCM_BOOL_T
);
952 for (p
= ra_rpsubrs
; p
->name
; p
++)
953 if (scm_is_eq (proc
, p
->sproc
))
955 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
957 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
960 return SCM_UNSPECIFIED
;
962 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
964 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, FUNC_NAME
);
967 return SCM_UNSPECIFIED
;
970 if (scm_is_null (lra
))
972 SCM fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
973 scm_array_fill_x (ra0
, fill
);
977 SCM tail
, ra1
= SCM_CAR (lra
);
978 SCM v0
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
980 /* Check to see if order might matter.
981 This might be an argument for a separate
983 if (scm_is_eq (v0
, ra1
)
984 || (SCM_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_ARRAY_V (ra1
))))
985 if (!scm_is_eq (ra0
, ra1
)
986 || (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
988 for (tail
= SCM_CDR (lra
); !scm_is_null (tail
); tail
= SCM_CDR (tail
))
990 ra1
= SCM_CAR (tail
);
991 if (scm_is_eq (v0
, ra1
)
992 || (SCM_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_ARRAY_V (ra1
))))
995 for (p
= ra_asubrs
; p
->name
; p
++)
996 if (scm_is_eq (proc
, p
->sproc
))
998 if (!scm_is_eq (ra0
, SCM_CAR (lra
)))
999 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), FUNC_NAME
);
1000 lra
= SCM_CDR (lra
);
1003 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
1004 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
1005 return SCM_UNSPECIFIED
;
1006 lra
= SCM_CDR (lra
);
1009 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
1010 lra
= SCM_CDR (lra
);
1012 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
1013 scm_ramapc (ramap_a
, proc
, ra0
, lra
, FUNC_NAME
);
1015 return SCM_UNSPECIFIED
;
1022 rafe (SCM ra0
, SCM proc
, SCM ras
)
1024 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1025 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1026 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1027 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1028 ra0
= SCM_ARRAY_V (ra0
);
1029 if (scm_is_null (ras
))
1030 for (; i
<= n
; i
++, i0
+= inc0
)
1031 scm_call_1 (proc
, scm_cvref (ra0
, i0
, SCM_UNDEFINED
));
1034 SCM ra1
= SCM_CAR (ras
);
1036 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
1037 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1038 ra1
= SCM_ARRAY_V (ra1
);
1039 ras
= SCM_CDR (ras
);
1040 if (scm_is_null(ras
))
1043 ras
= scm_vector (ras
);
1044 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
1047 for (k
= scm_c_vector_length (ras
); k
--;)
1048 args
= scm_cons (scm_c_generalized_vector_ref (scm_c_vector_ref (ras
, k
), i
), args
);
1049 args
= scm_cons2 (scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1050 scm_apply_0 (proc
, args
);
1057 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
1058 (SCM proc
, SCM ra0
, SCM lra
),
1059 "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
1060 "in row-major order. The value returned is unspecified.")
1061 #define FUNC_NAME s_scm_array_for_each
1063 SCM_VALIDATE_PROC (1, proc
);
1064 SCM_VALIDATE_REST_ARGUMENT (lra
);
1065 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
1066 return SCM_UNSPECIFIED
;
1070 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
1072 "Apply @var{proc} to the indices of each element of @var{array} in\n"
1073 "turn, storing the result in the corresponding element. The value\n"
1074 "returned and the order of application are unspecified.\n\n"
1075 "One can implement @var{array-indexes} as\n"
1077 "(define (array-indexes array)\n"
1078 " (let ((ra (apply make-array #f (array-shape array))))\n"
1079 " (array-index-map! ra (lambda x x))\n"
1082 "Another example:\n"
1084 "(define (apl:index-generator n)\n"
1085 " (let ((v (make-uniform-vector n 1)))\n"
1086 " (array-index-map! v (lambda (i) i))\n"
1089 #define FUNC_NAME s_scm_array_index_map_x
1092 SCM_VALIDATE_PROC (2, proc
);
1094 if (scm_is_generalized_vector (ra
))
1096 size_t length
= scm_c_generalized_vector_length (ra
);
1097 for (i
= 0; i
< length
; i
++)
1098 scm_c_generalized_vector_set_x (ra
, i
,
1099 scm_call_1 (proc
, scm_from_ulong (i
)));
1100 return SCM_UNSPECIFIED
;
1102 else if (SCM_ARRAYP (ra
))
1105 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
1109 return scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
1111 scm_frame_begin (0);
1113 vinds
= scm_malloc (sizeof(long) * SCM_ARRAY_NDIM (ra
));
1114 scm_frame_free (vinds
);
1116 for (k
= 0; k
<= kmax
; k
++)
1117 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1123 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1124 i
= cind (ra
, vinds
);
1125 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1127 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1128 args
= scm_cons (scm_from_long (vinds
[j
]), args
);
1129 scm_c_generalized_vector_set_x (SCM_ARRAY_V (ra
), i
,
1130 scm_apply_0 (proc
, args
));
1131 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1136 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1142 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1148 return SCM_UNSPECIFIED
;
1151 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1157 raeql_1 (SCM ra0
, SCM as_equal
, SCM ra1
)
1159 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1160 unsigned long i0
= 0, i1
= 0;
1161 long inc0
= 1, inc1
= 1;
1163 ra1
= SCM_CAR (ra1
);
1164 if (SCM_ARRAYP(ra0
))
1166 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1167 i0
= SCM_ARRAY_BASE (ra0
);
1168 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1169 ra0
= SCM_ARRAY_V (ra0
);
1172 n
= scm_c_generalized_vector_length (ra0
);
1174 if (SCM_ARRAYP (ra1
))
1176 i1
= SCM_ARRAY_BASE (ra1
);
1177 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1178 ra1
= SCM_ARRAY_V (ra1
);
1181 if (scm_is_generalized_vector (ra0
))
1183 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1185 if (scm_is_false (as_equal
))
1187 if (scm_is_false (scm_array_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1190 else if (scm_is_false (scm_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1202 raeql (SCM ra0
, SCM as_equal
, SCM ra1
)
1204 SCM v0
= ra0
, v1
= ra1
;
1205 scm_t_array_dim dim0
, dim1
;
1206 scm_t_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1207 unsigned long bas0
= 0, bas1
= 0;
1208 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1209 if (SCM_ARRAYP (ra0
))
1211 ndim
= SCM_ARRAY_NDIM (ra0
);
1212 s0
= SCM_ARRAY_DIMS (ra0
);
1213 bas0
= SCM_ARRAY_BASE (ra0
);
1214 v0
= SCM_ARRAY_V (ra0
);
1220 s0
->ubnd
= scm_c_generalized_vector_length (v0
) - 1;
1223 if (SCM_ARRAYP (ra1
))
1225 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
1227 s1
= SCM_ARRAY_DIMS (ra1
);
1228 bas1
= SCM_ARRAY_BASE (ra1
);
1229 v1
= SCM_ARRAY_V (ra1
);
1234 Huh ? Schizophrenic return type. --hwn
1240 s1
->ubnd
= scm_c_generalized_vector_length (v1
) - 1;
1243 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
1245 for (k
= ndim
; k
--;)
1247 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
1251 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
1252 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
1255 if (unroll
&& bas0
== bas1
&& scm_is_eq (v0
, v1
))
1257 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
1262 scm_raequal (SCM ra0
, SCM ra1
)
1264 return scm_from_bool(raeql (ra0
, SCM_BOOL_T
, ra1
));
1268 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1269 SCM_DEFINE1 (scm_array_equal_p
, "array-equal?", scm_tc7_rpsubr
,
1271 "Return @code{#t} iff all arguments are arrays with the same\n"
1272 "shape, the same type, and have corresponding elements which are\n"
1273 "either @code{equal?} or @code{array-equal?}. This function\n"
1274 "differs from @code{equal?} in that a one dimensional shared\n"
1275 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1276 "vector or uniform vector.")
1277 #define FUNC_NAME s_scm_array_equal_p
1283 static char s_array_equal_p
[] = "array-equal?";
1287 scm_array_equal_p (SCM ra0
, SCM ra1
)
1289 if (SCM_ARRAYP (ra0
) || SCM_ARRAYP (ra1
))
1290 return scm_from_bool(raeql (ra0
, SCM_BOOL_F
, ra1
));
1291 return scm_equal_p (ra0
, ra1
);
1296 init_raprocs (ra_iproc
*subra
)
1298 for (; subra
->name
; subra
++)
1300 SCM sym
= scm_from_locale_symbol (subra
->name
);
1302 scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_F
);
1303 if (var
!= SCM_BOOL_F
)
1304 subra
->sproc
= SCM_VARIABLE_REF (var
);
1306 subra
->sproc
= SCM_BOOL_F
;
1314 init_raprocs (ra_rpsubrs
);
1315 init_raprocs (ra_asubrs
);
1316 scm_c_define_subr (s_array_equal_p
, scm_tc7_rpsubr
, scm_array_equal_p
);
1317 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_array
)].equalp
= scm_raequal
;
1318 #include "libguile/ramap.x"
1319 scm_add_feature (s_scm_array_for_each
);