Import Upstream version 5e4upstream/5e4

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));
 }