X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/75a1b26c5d06e791afce10be9b1ab4e5272e45b4..dd1c7decccd35dc37950310b403b8e45a658fea4:/libguile/array-map.c

diff --git a/libguile/array-map.c b/libguile/array-map.c
index 1dc5d3bca..e47fb5641 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,6 +1,6 @@
 /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- *   2010, 2012, 2013 Free Software Foundation, Inc.
- *
+ *   2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
  * as published by the Free Software Foundation; either version 3 of
@@ -100,7 +100,7 @@ scm_ra_matchp (SCM ra0, SCM ras)
   else
     return 0;
 
-  while (SCM_NIMP (ras))
+  while (scm_is_pair (ras))
     {
       ra1 = SCM_CAR (ras);
       
@@ -205,7 +205,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
 	}
       lvra = SCM_EOL;
       plvra = &lvra;
-      for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+      for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
 	{
 	  ra1 = SCM_CAR (z);
 	  vra1 = scm_i_make_array (1);
@@ -263,7 +263,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
       }
     lvra = SCM_EOL;
     plvra = &lvra;
-    for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+    for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
       {
 	ra1 = SCM_CAR (z);
 	vra1 = scm_i_make_array (1);
@@ -296,7 +296,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
 	  {
 	    SCM y = lra;
 	    SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
-	    for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+	    for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
 	      SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
 	    if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
 	      return 0;
@@ -318,6 +318,23 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
     }
 }
 
+static int
+rafill (SCM dst, SCM fill)
+{
+  long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+  scm_t_array_handle h;
+  size_t i;
+  ssize_t inc;
+  scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
+  i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
+  inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+
+  for (; n-- > 0; i += inc)
+    h.impl->vset (&h, i, fill);
+
+  scm_array_handle_release (&h);
+  return 1;
+}
 
 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 	    (SCM ra, SCM fill),
@@ -325,31 +342,11 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 	    "returned is unspecified.")
 #define FUNC_NAME s_scm_array_fill_x
 {
-  scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
+  scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 
-/* to be used as cproc in scm_ramapc to fill an array dimension with
-   "fill". */
-int 
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-#define FUNC_NAME s_scm_array_fill_x
-{
-  unsigned long i;
-  unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
-  long inc = SCM_I_ARRAY_DIMS (ra)->inc;
-  unsigned long base = SCM_I_ARRAY_BASE (ra);
-
-  ra = SCM_I_ARRAY_V (ra);
-
-  for (i = base; n--; i += inc)
-    GVSET (ra, i, fill);
-
-  return 1;
-}
-#undef FUNC_NAME
-
 
 static int
 racp (SCM src, SCM dst)
@@ -360,8 +357,8 @@ racp (SCM src, SCM dst)
   ssize_t inc_s, inc_d;
 
   dst = SCM_CAR (dst);
-  scm_generalized_vector_get_handle (SCM_I_ARRAY_V (src), &h_s);
-  scm_generalized_vector_get_handle (SCM_I_ARRAY_V (dst), &h_d);
+  scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
+  scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
 
   i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
   i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
@@ -394,10 +391,29 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-/* Functions callable by ARRAY-MAP! */
 
 #if SCM_ENABLE_DEPRECATED == 1
 
+/* to be used as cproc in scm_ramapc to fill an array dimension with
+   "fill". */
+int
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
+{
+  unsigned long i;
+  unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
+  long inc = SCM_I_ARRAY_DIMS (ra)->inc;
+  unsigned long base = SCM_I_ARRAY_BASE (ra);
+
+  ra = SCM_I_ARRAY_V (ra);
+
+  for (i = base; n--; i += inc)
+    GVSET (ra, i, fill);
+
+  return 1;
+}
+
+/* Functions callable by ARRAY-MAP! */
+
 int
 scm_ra_eqp (SCM ra0, SCM ras)
 {
@@ -643,32 +659,47 @@ scm_array_identity (SCM dst, SCM src)
 static int
 ramap (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
-  long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
-  ra0 = SCM_I_ARRAY_V (ra0);
+  ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+  scm_t_array_handle h0;
+  size_t i0, i0end;
+  ssize_t inc0;
+  scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0end = i0 + n*inc0;
   if (scm_is_null (ras))
-    for (; i <= n; i++)
-      GVSET (ra0, i*inc+base, scm_call_0 (proc));
+    for (; i0 < i0end; i0 += inc0)
+      h0.impl->vset (&h0, i0, scm_call_0 (proc));
   else
     {
       SCM ra1 = SCM_CAR (ras);
-      SCM args;
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
-      ra1 = SCM_I_ARRAY_V (ra1);
-      ras = scm_vector (SCM_CDR (ras));
-      
-      for (; i <= n; i++, i1 += inc1)
-	{
-	  args = SCM_EOL;
-	  for (k = scm_c_vector_length (ras); k--;)
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-	  args = scm_cons (GVREF (ra1, i1), args);
-	  GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
-	}
+      scm_t_array_handle h1;
+      size_t i1;
+      ssize_t inc1;
+      scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
+      i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
+      inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
+      ras = SCM_CDR (ras);
+      if (scm_is_null (ras))
+          for (; i0 < i0end; i0 += inc0, i1 += inc1)
+            h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
+      else
+        {
+          ras = scm_vector (ras);
+          for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+            {
+              SCM args = SCM_EOL;
+              unsigned long k;
+              for (k = scm_c_vector_length (ras); k--;)
+                args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+              h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
+            }
+        }
+      scm_array_handle_release (&h1);
     }
+  scm_array_handle_release (&h0);
   return 1;
 }
 
@@ -701,36 +732,35 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 static int
 rafe (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
-  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
-  ra0 = SCM_I_ARRAY_V (ra0);
+  ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+
+  scm_t_array_handle h0;
+  size_t i0, i0end;
+  ssize_t inc0;
+  scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0end = i0 + n*inc0;
   if (scm_is_null (ras))
-    for (; i <= n; i++, i0 += inc0)
-      scm_call_1 (proc, GVREF (ra0, i0));
+    for (; i0 < i0end; i0 += inc0)
+      scm_call_1 (proc, h0.impl->vref (&h0, i0));
   else
     {
-      SCM ra1 = SCM_CAR (ras);
-      SCM args;
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
-      ra1 = SCM_I_ARRAY_V (ra1);
-      ras = scm_vector (SCM_CDR (ras));
-
-      for (; i <= n; i++, i0 += inc0, i1 += inc1)
-	{
-	  args = SCM_EOL;
-	  for (k = scm_c_vector_length (ras); k--;)
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-	  args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
-	  scm_apply_0 (proc, args);
-	}
+      ras = scm_vector (ras);
+      for (; i0 < i0end; i0 += inc0, ++i)
+        {
+          SCM args = SCM_EOL;
+          unsigned long k;
+          for (k = scm_c_vector_length (ras); k--;)
+            args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+          scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
+        }
     }
+  scm_array_handle_release (&h0);
   return 1;
 }
 
-
 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 	    (SCM proc, SCM ra0, SCM lra),
 	    "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"