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
},
79 #define GVREF scm_c_generalized_vector_ref
80 #define GVSET scm_c_generalized_vector_set_x
83 cind (SCM ra
, long *ve
)
89 i
= SCM_ARRAY_BASE (ra
);
90 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
91 i
+= (ve
[k
] - SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_ARRAY_DIMS (ra
)[k
].inc
;
96 /* Checker for scm_array mapping functions:
97 return values: 4 --> shapes, increments, and bases are the same;
98 3 --> shapes and increments are the same;
99 2 --> shapes are the same;
100 1 --> ras are at least as big as ra0;
105 scm_ra_matchp (SCM ra0
, SCM ras
)
108 scm_t_array_dim dims
;
109 scm_t_array_dim
*s0
= &dims
;
111 unsigned long bas0
= 0;
113 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
115 if (scm_is_generalized_vector (ra0
))
119 s0
->ubnd
= scm_c_generalized_vector_length (ra0
) - 1;
121 else if (SCM_ARRAYP (ra0
))
123 ndim
= SCM_ARRAY_NDIM (ra0
);
124 s0
= SCM_ARRAY_DIMS (ra0
);
125 bas0
= SCM_ARRAY_BASE (ra0
);
130 while (SCM_NIMP (ras
))
134 if (scm_is_generalized_vector (ra1
))
141 length
= scm_c_generalized_vector_length (ra1
);
152 if ((0 == s0
->lbnd
) && (s0
->ubnd
== length
- 1))
156 if (s0
->lbnd
< 0 || s0
->ubnd
>= length
)
160 else if (SCM_ARRAYP (ra1
) && ndim
== SCM_ARRAY_NDIM (ra1
))
162 s1
= SCM_ARRAY_DIMS (ra1
);
163 if (bas0
!= SCM_ARRAY_BASE (ra1
))
165 for (i
= 0; i
< ndim
; i
++)
170 if (s0
[i
].inc
!= s1
[i
].inc
)
173 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
177 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
178 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
190 /* array mapper: apply cproc to each dimension of the given arrays?.
191 int (*cproc) (); procedure to call on unrolled arrays?
192 cproc (dest, source list) or
193 cproc (dest, data, source list).
194 SCM data; data to give to cproc or unbound.
195 SCM ra0; destination array.
196 SCM lra; list of source arrays.
197 const char *what; caller, for error reporting. */
199 scm_ramapc (int (*cproc
)(), SCM data
, SCM ra0
, SCM lra
, const char *what
)
206 switch (scm_ra_matchp (ra0
, lra
))
210 scm_misc_error (what
, "array shape mismatch: ~S", scm_list_1 (ra0
));
213 case 4: /* Try unrolling arrays */
214 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
217 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
218 if (SCM_IMP (vra0
)) goto gencase
;
219 if (!SCM_ARRAYP (vra0
))
221 size_t length
= scm_c_generalized_vector_length (vra0
);
222 vra1
= scm_i_make_ra (1, 0);
223 SCM_ARRAY_BASE (vra1
) = 0;
224 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
225 SCM_ARRAY_DIMS (vra1
)->ubnd
= length
- 1;
226 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
227 SCM_ARRAY_V (vra1
) = vra0
;
232 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
235 vra1
= scm_i_make_ra (1, 0);
236 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
237 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
238 if (!SCM_ARRAYP (ra1
))
240 SCM_ARRAY_BASE (vra1
) = 0;
241 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
242 SCM_ARRAY_V (vra1
) = ra1
;
244 else if (!SCM_ARRAY_CONTP (ra1
))
248 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
249 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
250 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
252 *plvra
= scm_cons (vra1
, SCM_EOL
);
253 plvra
= SCM_CDRLOC (*plvra
);
255 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
257 gencase
: /* Have to loop over all dimensions. */
258 vra0
= scm_i_make_ra (1, 0);
259 if (SCM_ARRAYP (ra0
))
261 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
264 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
265 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
266 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
270 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
271 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
272 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
274 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
275 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
279 size_t length
= scm_c_generalized_vector_length (ra0
);
281 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
282 SCM_ARRAY_DIMS (vra0
)->ubnd
= length
- 1;
283 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
284 SCM_ARRAY_BASE (vra0
) = 0;
285 SCM_ARRAY_V (vra0
) = ra0
;
290 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
293 vra1
= scm_i_make_ra (1, 0);
294 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
295 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
296 if (SCM_ARRAYP (ra1
))
299 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
300 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
304 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
305 SCM_ARRAY_V (vra1
) = ra1
;
307 *plvra
= scm_cons (vra1
, SCM_EOL
);
308 plvra
= SCM_CDRLOC (*plvra
);
313 vinds
= scm_malloc (sizeof(long) * SCM_ARRAY_NDIM (ra0
));
314 scm_frame_free (vinds
);
316 for (k
= 0; k
<= kmax
; k
++)
317 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
324 SCM_ARRAY_BASE (vra0
) = cind (ra0
, vinds
);
325 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
326 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), vinds
);
327 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
332 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
338 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
349 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
351 "Store @var{fill} in every element of @var{array}. The value returned\n"
353 #define FUNC_NAME s_scm_array_fill_x
355 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
356 return SCM_UNSPECIFIED
;
360 /* to be used as cproc in scm_ramapc to fill an array dimension with
363 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
364 #define FUNC_NAME s_scm_array_fill_x
367 unsigned long n
= SCM_ARRAY_DIMS (ra
)->ubnd
- SCM_ARRAY_DIMS (ra
)->lbnd
+ 1;
368 long inc
= SCM_ARRAY_DIMS (ra
)->inc
;
369 unsigned long base
= SCM_ARRAY_BASE (ra
);
371 ra
= SCM_ARRAY_V (ra
);
373 for (i
= base
; n
--; i
+= inc
)
383 racp (SCM src
, SCM dst
)
385 long n
= (SCM_ARRAY_DIMS (src
)->ubnd
- SCM_ARRAY_DIMS (src
)->lbnd
+ 1);
386 long inc_d
, inc_s
= SCM_ARRAY_DIMS (src
)->inc
;
387 unsigned long i_d
, i_s
= SCM_ARRAY_BASE (src
);
389 inc_d
= SCM_ARRAY_DIMS (dst
)->inc
;
390 i_d
= SCM_ARRAY_BASE (dst
);
391 src
= SCM_ARRAY_V (src
);
392 dst
= SCM_ARRAY_V (dst
);
394 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
395 GVSET (dst
, i_d
, GVREF (src
, i_s
));
399 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
402 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
404 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
405 "Copy every element from vector or array @var{source} to the\n"
406 "corresponding element of @var{destination}. @var{destination} must have\n"
407 "the same rank as @var{source}, and be at least as large in each\n"
408 "dimension. The order is unspecified.")
409 #define FUNC_NAME s_scm_array_copy_x
411 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
412 return SCM_UNSPECIFIED
;
416 /* Functions callable by ARRAY-MAP! */
420 scm_ra_eqp (SCM ra0
, SCM ras
)
422 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
423 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
424 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
425 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
426 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
427 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
428 ra0
= SCM_ARRAY_V (ra0
);
429 ra1
= SCM_ARRAY_V (ra1
);
430 ra2
= SCM_ARRAY_V (ra2
);
433 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
434 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
435 if (!scm_is_eq (GVREF (ra1
, i1
), GVREF (ra2
, i2
)))
436 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
442 /* opt 0 means <, nonzero means >= */
445 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
447 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
448 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
449 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
450 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
451 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
452 ra0
= SCM_ARRAY_V (ra0
);
453 ra1
= SCM_ARRAY_V (ra1
);
454 ra2
= SCM_ARRAY_V (ra2
);
457 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
458 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
460 scm_is_true (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))) :
461 scm_is_false (scm_less_p (GVREF (ra1
, i1
), GVREF (ra2
, i2
))))
462 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
471 scm_ra_lessp (SCM ra0
, SCM ras
)
473 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
478 scm_ra_leqp (SCM ra0
, SCM ras
)
480 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
485 scm_ra_grp (SCM ra0
, SCM ras
)
487 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
492 scm_ra_greqp (SCM ra0
, SCM ras
)
494 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
499 scm_ra_sum (SCM ra0
, SCM ras
)
501 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
502 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
503 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
504 ra0
= SCM_ARRAY_V (ra0
);
505 if (!scm_is_null(ras
))
507 SCM ra1
= SCM_CAR (ras
);
508 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
509 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
510 ra1
= SCM_ARRAY_V (ra1
);
511 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
515 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
516 GVSET (ra0
, i0
, scm_sum (GVREF(ra0
, i0
), GVREF(ra1
, i1
)));
527 scm_ra_difference (SCM ra0
, SCM ras
)
529 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
530 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
531 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
532 ra0
= SCM_ARRAY_V (ra0
);
533 if (scm_is_null (ras
))
535 switch (SCM_TYP7 (ra0
))
539 for (; n
-- > 0; i0
+= inc0
)
540 GVSET (ra0
, i0
, scm_difference (GVREF(ra0
, i0
), SCM_UNDEFINED
));
547 SCM ra1
= SCM_CAR (ras
);
548 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
549 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
550 ra1
= SCM_ARRAY_V (ra1
);
551 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
555 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
556 GVSET (ra0
, i0
, scm_difference (GVREF (ra0
, i0
),
568 scm_ra_product (SCM ra0
, SCM ras
)
570 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
571 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
572 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
573 ra0
= SCM_ARRAY_V (ra0
);
574 if (!scm_is_null (ras
))
576 SCM ra1
= SCM_CAR (ras
);
577 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
578 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
579 ra1
= SCM_ARRAY_V (ra1
);
580 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
584 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
585 GVSET (ra0
, i0
, scm_product (GVREF (ra0
, i0
),
595 scm_ra_divide (SCM ra0
, SCM ras
)
597 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
598 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
599 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
600 ra0
= SCM_ARRAY_V (ra0
);
601 if (scm_is_null (ras
))
603 switch (SCM_TYP7 (ra0
))
607 for (; n
-- > 0; i0
+= inc0
)
608 GVSET (ra0
, i0
, scm_divide (GVREF (ra0
, i0
), SCM_UNDEFINED
));
615 SCM ra1
= SCM_CAR (ras
);
616 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
617 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
618 ra1
= SCM_ARRAY_V (ra1
);
619 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
623 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
625 SCM res
= scm_divide (GVREF (ra0
, i0
),
627 GVSET (ra0
, i0
, res
);
638 scm_array_identity (SCM dst
, SCM src
)
640 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
646 ramap (SCM ra0
, SCM proc
, SCM ras
)
648 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
649 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
650 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
651 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
652 ra0
= SCM_ARRAY_V (ra0
);
653 if (scm_is_null (ras
))
655 GVSET (ra0
, i
*inc
+base
, scm_call_0 (proc
));
658 SCM ra1
= SCM_CAR (ras
);
660 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
661 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
662 ra1
= SCM_ARRAY_V (ra1
);
664 if (scm_is_null(ras
))
667 ras
= scm_vector (ras
);
669 for (; i
<= n
; i
++, i1
+= inc1
)
672 for (k
= scm_c_vector_length (ras
); k
--;)
673 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
674 args
= scm_cons (GVREF (ra1
, i1
), args
);
675 GVSET (ra0
, i
*inc
+base
, scm_apply_0 (proc
, args
));
683 ramap_dsubr (SCM ra0
, SCM proc
, SCM ras
)
685 SCM ra1
= SCM_CAR (ras
);
686 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
687 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
688 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
689 ra0
= SCM_ARRAY_V (ra0
);
690 ra1
= SCM_ARRAY_V (ra1
);
691 switch (SCM_TYP7 (ra0
))
694 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
695 GVSET (ra0
, i0
, scm_call_1 (proc
, GVREF (ra1
, i1
)));
704 ramap_rp (SCM ra0
, SCM proc
, SCM ras
)
706 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
707 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
708 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
709 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
710 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
711 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
712 ra0
= SCM_ARRAY_V (ra0
);
713 ra1
= SCM_ARRAY_V (ra1
);
714 ra2
= SCM_ARRAY_V (ra2
);
716 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
717 if (scm_is_true (scm_c_bitvector_ref (ra0
, i0
)))
718 if (scm_is_false (SCM_SUBRF (proc
) (GVREF (ra1
, i1
), GVREF (ra2
, i2
))))
719 scm_c_bitvector_set_x (ra0
, i0
, SCM_BOOL_F
);
727 ramap_1 (SCM ra0
, SCM proc
, SCM ras
)
729 SCM ra1
= SCM_CAR (ras
);
730 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
731 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
732 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
733 ra0
= SCM_ARRAY_V (ra0
);
734 ra1
= SCM_ARRAY_V (ra1
);
735 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
736 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
737 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
)));
739 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
740 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
)));
747 ramap_2o (SCM ra0
, SCM proc
, SCM ras
)
749 SCM ra1
= SCM_CAR (ras
);
750 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
751 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
752 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
753 ra0
= SCM_ARRAY_V (ra0
);
754 ra1
= SCM_ARRAY_V (ra1
);
756 if (scm_is_null (ras
))
758 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
759 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
), SCM_UNDEFINED
));
763 SCM ra2
= SCM_CAR (ras
);
764 unsigned long i2
= SCM_ARRAY_BASE (ra2
);
765 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
766 ra2
= SCM_ARRAY_V (ra2
);
767 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
768 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra1
, i1
), GVREF (ra2
, i2
)));
776 ramap_a (SCM ra0
, SCM proc
, SCM ras
)
778 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
779 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
780 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
781 ra0
= SCM_ARRAY_V (ra0
);
782 if (scm_is_null (ras
))
783 for (; n
-- > 0; i0
+= inc0
)
784 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra0
, i0
), SCM_UNDEFINED
));
787 SCM ra1
= SCM_CAR (ras
);
788 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
789 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
790 ra1
= SCM_ARRAY_V (ra1
);
791 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
792 GVSET (ra0
, i0
, SCM_SUBRF (proc
) (GVREF (ra0
, i0
), GVREF (ra1
, i1
)));
798 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
801 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
802 (SCM ra0
, SCM proc
, SCM lra
),
803 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
804 "@var{array1}, @dots{} must have the same number of dimensions as\n"
805 "@var{array0} and have a range for each index which includes the range\n"
806 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
807 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
808 "as the corresponding element in @var{array0}. The value returned is\n"
809 "unspecified. The order of application is unspecified.")
810 #define FUNC_NAME s_scm_array_map_x
812 SCM_VALIDATE_PROC (2, proc
);
813 SCM_VALIDATE_REST_ARGUMENT (lra
);
814 /* This is done as a test on lra, rather than an extra mandatory parameter
815 eval could check, so that the prototype for scm_array_map_x stays as it
816 was in the past. scm_array_map_x isn't actually documented, but did
817 get a mention in the NEWS file, so is best left alone. */
818 if (scm_is_null (lra
))
819 SCM_WRONG_NUM_ARGS ();
820 switch (SCM_TYP7 (proc
))
824 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
825 return SCM_UNSPECIFIED
;
827 scm_ramapc (ramap_1
, proc
, ra0
, lra
, FUNC_NAME
);
828 return SCM_UNSPECIFIED
;
830 case scm_tc7_subr_2o
:
831 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
832 return SCM_UNSPECIFIED
;
834 scm_ramapc (ramap_dsubr
, proc
, ra0
, lra
, FUNC_NAME
);
835 return SCM_UNSPECIFIED
;
839 if (scm_is_false (scm_array_p (ra0
, SCM_BOOL_T
)))
841 scm_array_fill_x (ra0
, SCM_BOOL_T
);
842 for (p
= ra_rpsubrs
; p
->name
; p
++)
843 if (scm_is_eq (proc
, p
->sproc
))
845 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
847 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
850 return SCM_UNSPECIFIED
;
852 while (!scm_is_null (lra
) && !scm_is_null (SCM_CDR (lra
)))
854 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, FUNC_NAME
);
857 return SCM_UNSPECIFIED
;
860 if (scm_is_null (lra
))
862 SCM fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
863 scm_array_fill_x (ra0
, fill
);
867 SCM tail
, ra1
= SCM_CAR (lra
);
868 SCM v0
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
870 /* Check to see if order might matter.
871 This might be an argument for a separate
873 if (scm_is_eq (v0
, ra1
)
874 || (SCM_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_ARRAY_V (ra1
))))
875 if (!scm_is_eq (ra0
, ra1
)
876 || (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
878 for (tail
= SCM_CDR (lra
); !scm_is_null (tail
); tail
= SCM_CDR (tail
))
880 ra1
= SCM_CAR (tail
);
881 if (scm_is_eq (v0
, ra1
)
882 || (SCM_ARRAYP (ra1
) && scm_is_eq (v0
, SCM_ARRAY_V (ra1
))))
885 for (p
= ra_asubrs
; p
->name
; p
++)
886 if (scm_is_eq (proc
, p
->sproc
))
888 if (!scm_is_eq (ra0
, SCM_CAR (lra
)))
889 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), FUNC_NAME
);
893 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
894 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
895 return SCM_UNSPECIFIED
;
899 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
902 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
903 scm_ramapc (ramap_a
, proc
, ra0
, lra
, FUNC_NAME
);
905 return SCM_UNSPECIFIED
;
912 rafe (SCM ra0
, SCM proc
, SCM ras
)
914 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
915 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
916 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
917 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
918 ra0
= SCM_ARRAY_V (ra0
);
919 if (scm_is_null (ras
))
920 for (; i
<= n
; i
++, i0
+= inc0
)
921 scm_call_1 (proc
, GVREF (ra0
, i0
));
924 SCM ra1
= SCM_CAR (ras
);
926 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
927 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
928 ra1
= SCM_ARRAY_V (ra1
);
930 if (scm_is_null(ras
))
933 ras
= scm_vector (ras
);
934 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
937 for (k
= scm_c_vector_length (ras
); k
--;)
938 args
= scm_cons (GVREF (scm_c_vector_ref (ras
, k
), i
), args
);
939 args
= scm_cons2 (GVREF (ra0
, i0
), GVREF (ra1
, i1
), args
);
940 scm_apply_0 (proc
, args
);
947 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
948 (SCM proc
, SCM ra0
, SCM lra
),
949 "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
950 "in row-major order. The value returned is unspecified.")
951 #define FUNC_NAME s_scm_array_for_each
953 SCM_VALIDATE_PROC (1, proc
);
954 SCM_VALIDATE_REST_ARGUMENT (lra
);
955 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
956 return SCM_UNSPECIFIED
;
960 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
962 "Apply @var{proc} to the indices of each element of @var{array} in\n"
963 "turn, storing the result in the corresponding element. The value\n"
964 "returned and the order of application are unspecified.\n\n"
965 "One can implement @var{array-indexes} as\n"
967 "(define (array-indexes array)\n"
968 " (let ((ra (apply make-array #f (array-shape array))))\n"
969 " (array-index-map! ra (lambda x x))\n"
974 "(define (apl:index-generator n)\n"
975 " (let ((v (make-uniform-vector n 1)))\n"
976 " (array-index-map! v (lambda (i) i))\n"
979 #define FUNC_NAME s_scm_array_index_map_x
982 SCM_VALIDATE_PROC (2, proc
);
984 if (scm_is_generalized_vector (ra
))
986 size_t length
= scm_c_generalized_vector_length (ra
);
987 for (i
= 0; i
< length
; i
++)
988 GVSET (ra
, i
, scm_call_1 (proc
, scm_from_ulong (i
)));
989 return SCM_UNSPECIFIED
;
991 else if (SCM_ARRAYP (ra
))
994 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
998 return scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
1000 scm_frame_begin (0);
1002 vinds
= scm_malloc (sizeof(long) * SCM_ARRAY_NDIM (ra
));
1003 scm_frame_free (vinds
);
1005 for (k
= 0; k
<= kmax
; k
++)
1006 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1012 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1013 i
= cind (ra
, vinds
);
1014 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1016 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1017 args
= scm_cons (scm_from_long (vinds
[j
]), args
);
1018 GVSET (SCM_ARRAY_V (ra
), i
, scm_apply_0 (proc
, args
));
1019 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1024 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1030 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1036 return SCM_UNSPECIFIED
;
1039 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1045 raeql_1 (SCM ra0
, SCM as_equal
, SCM ra1
)
1047 unsigned long i0
= 0, i1
= 0;
1048 long inc0
= 1, inc1
= 1;
1050 ra1
= SCM_CAR (ra1
);
1051 if (SCM_ARRAYP(ra0
))
1053 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1054 i0
= SCM_ARRAY_BASE (ra0
);
1055 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1056 ra0
= SCM_ARRAY_V (ra0
);
1059 n
= scm_c_generalized_vector_length (ra0
);
1061 if (SCM_ARRAYP (ra1
))
1063 i1
= SCM_ARRAY_BASE (ra1
);
1064 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1065 ra1
= SCM_ARRAY_V (ra1
);
1068 if (scm_is_generalized_vector (ra0
))
1070 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1072 if (scm_is_false (as_equal
))
1074 if (scm_is_false (scm_array_equal_p (GVREF (ra0
, i0
), GVREF (ra1
, i1
))))
1077 else if (scm_is_false (scm_equal_p (GVREF (ra0
, i0
), GVREF (ra1
, i1
))))
1089 raeql (SCM ra0
, SCM as_equal
, SCM ra1
)
1091 SCM v0
= ra0
, v1
= ra1
;
1092 scm_t_array_dim dim0
, dim1
;
1093 scm_t_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1094 unsigned long bas0
= 0, bas1
= 0;
1095 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1096 if (SCM_ARRAYP (ra0
))
1098 ndim
= SCM_ARRAY_NDIM (ra0
);
1099 s0
= SCM_ARRAY_DIMS (ra0
);
1100 bas0
= SCM_ARRAY_BASE (ra0
);
1101 v0
= SCM_ARRAY_V (ra0
);
1107 s0
->ubnd
= scm_c_generalized_vector_length (v0
) - 1;
1110 if (SCM_ARRAYP (ra1
))
1112 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
1114 s1
= SCM_ARRAY_DIMS (ra1
);
1115 bas1
= SCM_ARRAY_BASE (ra1
);
1116 v1
= SCM_ARRAY_V (ra1
);
1121 Huh ? Schizophrenic return type. --hwn
1127 s1
->ubnd
= scm_c_generalized_vector_length (v1
) - 1;
1130 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
1132 for (k
= ndim
; k
--;)
1134 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
1138 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
1139 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
1142 if (unroll
&& bas0
== bas1
&& scm_is_eq (v0
, v1
))
1144 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
1149 scm_raequal (SCM ra0
, SCM ra1
)
1151 return scm_from_bool(raeql (ra0
, SCM_BOOL_T
, ra1
));
1155 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1156 SCM_DEFINE1 (scm_array_equal_p
, "array-equal?", scm_tc7_rpsubr
,
1158 "Return @code{#t} iff all arguments are arrays with the same\n"
1159 "shape, the same type, and have corresponding elements which are\n"
1160 "either @code{equal?} or @code{array-equal?}. This function\n"
1161 "differs from @code{equal?} in that a one dimensional shared\n"
1162 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1163 "vector or uniform vector.")
1164 #define FUNC_NAME s_scm_array_equal_p
1170 static char s_array_equal_p
[] = "array-equal?";
1174 scm_array_equal_p (SCM ra0
, SCM ra1
)
1176 if (SCM_ARRAYP (ra0
) || SCM_ARRAYP (ra1
))
1177 return scm_from_bool(raeql (ra0
, SCM_BOOL_F
, ra1
));
1178 return scm_equal_p (ra0
, ra1
);
1183 init_raprocs (ra_iproc
*subra
)
1185 for (; subra
->name
; subra
++)
1187 SCM sym
= scm_from_locale_symbol (subra
->name
);
1189 scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_F
);
1190 if (var
!= SCM_BOOL_F
)
1191 subra
->sproc
= SCM_VARIABLE_REF (var
);
1193 subra
->sproc
= SCM_BOOL_F
;
1201 init_raprocs (ra_rpsubrs
);
1202 init_raprocs (ra_asubrs
);
1203 scm_c_define_subr (s_array_equal_p
, scm_tc7_rpsubr
, scm_array_equal_p
);
1204 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_array
)].equalp
= scm_raequal
;
1205 #include "libguile/ramap.x"
1206 scm_add_feature (s_scm_array_for_each
);