diff options
Diffstat (limited to 'ramap.c')
| -rw-r--r-- | ramap.c | 76 |
1 files changed, 74 insertions, 2 deletions
@@ -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)); } |