aboutsummaryrefslogtreecommitdiffstats
path: root/ramap.c
diff options
context:
space:
mode:
Diffstat (limited to 'ramap.c')
-rw-r--r--ramap.c76
1 files changed, 74 insertions, 2 deletions
diff --git a/ramap.c b/ramap.c
index 53357e7..ad3a74e 100644
--- a/ramap.c
+++ b/ramap.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+/* Copyright (C) 1994, 1995, 2006 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -1546,6 +1546,77 @@ SCM array_for_each(proc, ra0, lra)
}
}
+static char s_array_index_for_each[] = "array-index-for-each";
+SCM scm_array_index_for_each(ra, proc)
+ SCM ra, proc;
+{
+ SCM hp_av, hp_indv, auto_av[5];
+ SCM *av = &auto_av[0];
+ long auto_indv[5];
+ long *indv = &auto_indv[0];
+ sizet i;
+ ASRTER(NIMP(ra), ra, ARG1, s_array_index_for_each);
+ i = INUM(array_rank(ra));
+#ifndef RECKLESS
+ scm_arity_check(proc, i+0L, s_array_index_for_each);
+#endif
+ if (i >= 5) {
+ scm_protect_temp(&hp_av);
+ scm_protect_temp(&hp_indv);
+ hp_av = make_vector(MAKINUM(i), BOOL_F);
+ av = VELTS(hp_av);
+ hp_indv = make_uve(i+0L, MAKINUM(-32L));
+ indv = (long *)VELTS(hp_indv);
+ }
+ switch TYP7(ra) {
+ default: badarg: wta(ra, (char *)ARG1, s_array_index_for_each);
+ case tc7_vector: {
+ for (i = 0; i < LENGTH(ra); i++) {
+ av[0] = MAKINUM(i);
+ scm_cvapply(proc, 1L, av);
+ }
+ return UNSPECIFIED;
+ }
+ case tcs_uves:
+ for (i = 0; i < LENGTH(ra); i++) {
+ av[0] = MAKINUM(i);
+ scm_cvapply(proc, 1L, auto_av);
+ }
+ return UNSPECIFIED;
+ case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
+ {
+ int j, k, kmax = ARRAY_NDIM(ra) - 1;
+ if (kmax < 0)
+ return apply(proc, EOL, EOL);
+ for (k = 0; k <= kmax; k++)
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd;
+ k = kmax;
+ do {
+ if (k==kmax) {
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd;
+ i = cind(ra, indv);
+ for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
+ for (j = kmax+1; j--;)
+ av[j] = MAKINUM(indv[j]);
+ scm_cvapply(proc, kmax+1L, av);
+ i += ARRAY_DIMS(ra)[k].inc;
+ }
+ k--;
+ continue;
+ }
+ if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
+ indv[k]++;
+ k++;
+ continue;
+ }
+ indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
+ k--;
+ } while (k >= 0);
+ return UNSPECIFIED;
+ }
+ }
+}
+
static char s_array_imap[] = "array-index-map!";
SCM array_imap(ra, proc)
SCM ra, proc;
@@ -1788,12 +1859,13 @@ static iproc lsubr2s[] = {
{s_sarray_map, array_map},
{s_array_for_each, array_for_each},
{s_array_imap, array_imap},
+ {s_array_index_for_each, scm_array_index_for_each},
{0, 0}};
static void init_raprocs(subra)
ra_iproc *subra;
{
- for(; subra->name; subra++)
+ for (; subra->name; subra++)
subra->sproc = CDR(sysintern(subra->name, UNDEFINED));
}