libguile/array-map.c

   1 /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
   2  *   2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22
  23
  24 \f
  25 #ifdef HAVE_CONFIG_H
  26 # include <config.h>
  27 #endif
  28
  29 #include "libguile/_scm.h"
  30 #include "libguile/strings.h"
  31 #include "libguile/arrays.h"
  32 #include "libguile/smob.h"
  33 #include "libguile/chars.h"
  34 #include "libguile/eq.h"
  35 #include "libguile/eval.h"
  36 #include "libguile/feature.h"
  37 #include "libguile/root.h"
  38 #include "libguile/vectors.h"
  39 #include "libguile/bitvectors.h"
  40 #include "libguile/srfi-4.h"
  41 #include "libguile/generalized-arrays.h"
  42
  43 #include "libguile/validate.h"
  44 #include "libguile/array-map.h"
  45 \f
  46
  47 /* The WHAT argument for `scm_gc_malloc ()' et al.  */
  48 static const char indices_gc_hint[] = "array-indices";
  49
  50 static SCM
  51 AREF (SCM v, size_t pos)
  52 {
  53   return scm_c_array_ref_1 (v, pos);
  54 }
  55
  56 static void
  57 ASET (SCM v, size_t pos, SCM val)
  58 {
  59   scm_c_array_set_1_x (v, val, pos);
  60 }
  61
  62 static unsigned long
  63 cind (SCM ra, long *ve)
  64 {
  65   unsigned long i;
  66   int k;
  67   if (!SCM_I_ARRAYP (ra))
  68     return *ve;
  69   i = SCM_I_ARRAY_BASE (ra);
  70   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
  71     i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
  72   return i;
  73 }
  74
  75
  76 /* Checker for scm_array mapping functions:
  77    return values: 4 --> shapes, increments, and bases are the same;
  78    3 --> shapes and increments are the same;
  79    2 --> shapes are the same;
  80    1 --> ras are at least as big as ra0;
  81    0 --> no match.
  82    */
  83
  84 int
  85 scm_ra_matchp (SCM ra0, SCM ras)
  86 {
  87   SCM ra1;
  88   scm_t_array_dim dims;
  89   scm_t_array_dim *s0 = &dims;
  90   scm_t_array_dim *s1;
  91   unsigned long bas0 = 0;
  92   int i, ndim = 1;
  93   int exact = 2   /* 4 */ ;  /* Don't care about values >2 (yet?) */
  94
  95   if (SCM_I_ARRAYP (ra0))
  96     {
  97       ndim = SCM_I_ARRAY_NDIM (ra0);
  98       s0 = SCM_I_ARRAY_DIMS (ra0);
  99       bas0 = SCM_I_ARRAY_BASE (ra0);
 100     }
 101   else if (scm_is_array (ra0))
 102     {
 103       s0->lbnd = 0;
 104       s0->inc = 1;
 105       s0->ubnd = scm_c_array_length (ra0) - 1;
 106     }
 107   else
 108     return 0;
 109
 110   while (scm_is_pair (ras))
 111     {
 112       ra1 = SCM_CAR (ras);
 113
 114       if (!SCM_I_ARRAYP (ra1))
 115         {
 116           size_t length;
 117
 118           if (1 != ndim)
 119             return 0;
 120
 121           length = scm_c_array_length (ra1);
 122
 123           switch (exact)
 124             {
 125             case 4:
 126               if (0 != bas0)
 127                 exact = 3;
 128             case 3:
 129               if (1 != s0->inc)
 130                 exact = 2;
 131             case 2:
 132               if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
 133                 break;
 134               exact = 1;
 135             case 1:
 136               if (s0->lbnd < 0 || s0->ubnd >= length)
 137                 return 0;
 138             }
 139         }
 140       else if (ndim == SCM_I_ARRAY_NDIM (ra1))
 141         {
 142           s1 = SCM_I_ARRAY_DIMS (ra1);
 143           if (bas0 != SCM_I_ARRAY_BASE (ra1))
 144             exact = 3;
 145           for (i = 0; i < ndim; i++)
 146             switch (exact)
 147               {
 148               case 4:
 149               case 3:
 150                 if (s0[i].inc != s1[i].inc)
 151                   exact = 2;
 152               case 2:
 153                 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
 154                   break;
 155                 exact = 1;
 156               default:
 157                 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
 158                   return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
 159               }
 160         }
 161       else
 162         return 0;
 163
 164       ras = SCM_CDR (ras);
 165     }
 166
 167   return exact;
 168 }
 169
 170 /* array mapper: apply cproc to each dimension of the given arrays?.
 171      int (*cproc) ();   procedure to call on unrolled arrays?
 172                            cproc (dest, source list) or
 173                            cproc (dest, data, source list).
 174      SCM data;          data to give to cproc or unbound.
 175      SCM ra0;           destination array.
 176      SCM lra;           list of source arrays.
 177      const char *what;  caller, for error reporting. */
 178 int
 179 scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
 180 {
 181   SCM z;
 182   SCM vra0, ra1, vra1;
 183   SCM lvra, *plvra;
 184   long *vinds;
 185   int k, kmax;
 186   int (*cproc) () = cproc_ptr;
 187
 188   switch (scm_ra_matchp (ra0, lra))
 189     {
 190     default:
 191     case 0:
 192       scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
 193     case 2:
 194     case 3:
 195     case 4:                     /* Try unrolling arrays */
 196       kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
 197       if (kmax < 0)
 198         goto gencase;
 199       vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
 200       if (SCM_IMP (vra0)) goto gencase;
 201       if (!SCM_I_ARRAYP (vra0))
 202         {
 203           size_t length = scm_c_array_length (vra0);
 204           vra1 = scm_i_make_array (1);
 205           SCM_I_ARRAY_BASE (vra1) = 0;
 206           SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
 207           SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
 208           SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 209           SCM_I_ARRAY_V (vra1) = vra0;
 210           vra0 = vra1;
 211         }
 212       lvra = SCM_EOL;
 213       plvra = &lvra;
 214       for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
 215         {
 216           ra1 = SCM_CAR (z);
 217           vra1 = scm_i_make_array (1);
 218           SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 219           SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 220           if (!SCM_I_ARRAYP (ra1))
 221             {
 222               SCM_I_ARRAY_BASE (vra1) = 0;
 223               SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 224               SCM_I_ARRAY_V (vra1) = ra1;
 225             }
 226           else if (!SCM_I_ARRAY_CONTP (ra1))
 227             goto gencase;
 228           else
 229             {
 230               SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
 231               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 232               SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 233             }
 234           *plvra = scm_cons (vra1, SCM_EOL);
 235           plvra = SCM_CDRLOC (*plvra);
 236         }
 237       return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
 238     case 1:
 239     gencase:                    /* Have to loop over all dimensions. */
 240       vra0 = scm_i_make_array (1);
 241     if (SCM_I_ARRAYP (ra0))
 242       {
 243         kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
 244         if (kmax < 0)
 245           {
 246             SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 247             SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
 248             SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 249           }
 250         else
 251           {
 252             SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
 253             SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
 254             SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
 255           }
 256         SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
 257         SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
 258       }
 259     else
 260       {
 261         size_t length = scm_c_array_length (ra0);
 262         kmax = 0;
 263         SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 264         SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
 265         SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 266         SCM_I_ARRAY_BASE (vra0) = 0;
 267         SCM_I_ARRAY_V (vra0) = ra0;
 268         ra0 = vra0;
 269       }
 270     lvra = SCM_EOL;
 271     plvra = &lvra;
 272     for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
 273       {
 274         ra1 = SCM_CAR (z);
 275         vra1 = scm_i_make_array (1);
 276         SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 277         SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 278         if (SCM_I_ARRAYP (ra1))
 279           {
 280             if (kmax >= 0)
 281               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 282             SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 283           }
 284         else
 285           {
 286             SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 287             SCM_I_ARRAY_V (vra1) = ra1;
 288           }
 289         *plvra = scm_cons (vra1, SCM_EOL);
 290         plvra = SCM_CDRLOC (*plvra);
 291       }
 292
 293     vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
 294                                        indices_gc_hint);
 295
 296     for (k = 0; k <= kmax; k++)
 297       vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
 298     k = kmax;
 299     do
 300       {
 301         if (k == kmax)
 302           {
 303             SCM y = lra;
 304             SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
 305             for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
 306               SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
 307             if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
 308               return 0;
 309             k--;
 310             continue;
 311           }
 312         if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
 313           {
 314             vinds[k]++;
 315             k++;
 316             continue;
 317           }
 318         vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
 319         k--;
 320       }
 321     while (k >= 0);
 322
 323     return 1;
 324     }
 325 }
 326
 327 static int
 328 rafill (SCM dst, SCM fill)
 329 {
 330   long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
 331   scm_t_array_handle h;
 332   size_t i;
 333   ssize_t inc;
 334   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
 335   i = SCM_I_ARRAY_BASE (dst);
 336   inc = SCM_I_ARRAY_DIMS (dst)->inc;
 337
 338   for (; n-- > 0; i += inc)
 339     h.impl->vset (&h, i, fill);
 340
 341   scm_array_handle_release (&h);
 342   return 1;
 343 }
 344
 345 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 346             (SCM ra, SCM fill),
 347             "Store @var{fill} in every element of array @var{ra}.  The value\n"
 348             "returned is unspecified.")
 349 #define FUNC_NAME s_scm_array_fill_x
 350 {
 351   scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
 352   return SCM_UNSPECIFIED;
 353 }
 354 #undef FUNC_NAME
 355
 356
 357 static int
 358 racp (SCM src, SCM dst)
 359 {
 360   long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
 361   scm_t_array_handle h_s, h_d;
 362   size_t i_s, i_d;
 363   ssize_t inc_s, inc_d;
 364
 365   dst = SCM_CAR (dst);
 366   scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
 367   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
 368
 369   i_s = SCM_I_ARRAY_BASE (src);
 370   i_d = SCM_I_ARRAY_BASE (dst);
 371   inc_s = SCM_I_ARRAY_DIMS (src)->inc;
 372   inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
 373
 374   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
 375     h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
 376
 377   scm_array_handle_release (&h_d);
 378   scm_array_handle_release (&h_s);
 379
 380   return 1;
 381 }
 382
 383 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
 384
 385
 386 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 387             (SCM src, SCM dst),
 388             "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
 389             "Copy every element from vector or array @var{src} to the\n"
 390             "corresponding element of @var{dst}.  @var{dst} must have the\n"
 391             "same rank as @var{src}, and be at least as large in each\n"
 392             "dimension.  The order is unspecified.")
 393 #define FUNC_NAME s_scm_array_copy_x
 394 {
 395   scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
 396   return SCM_UNSPECIFIED;
 397 }
 398 #undef FUNC_NAME
 399
 400
 401 #if SCM_ENABLE_DEPRECATED == 1
 402
 403 /* to be used as cproc in scm_ramapc to fill an array dimension with
 404    "fill". */
 405 int
 406 scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
 407 {
 408   unsigned long i;
 409   unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
 410   long inc = SCM_I_ARRAY_DIMS (ra)->inc;
 411   unsigned long base = SCM_I_ARRAY_BASE (ra);
 412
 413   ra = SCM_I_ARRAY_V (ra);
 414
 415   for (i = base; n--; i += inc)
 416     ASET (ra, i, fill);
 417
 418   return 1;
 419 }
 420
 421 /* Functions callable by ARRAY-MAP! */
 422
 423 int
 424 scm_ra_eqp (SCM ra0, SCM ras)
 425 {
 426   SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
 427   scm_t_array_handle ra0_handle;
 428   scm_t_array_dim *ra0_dims;
 429   size_t n;
 430   ssize_t inc0;
 431   size_t i0 = 0;
 432   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 433   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 434   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 435   ra1 = SCM_I_ARRAY_V (ra1);
 436   ra2 = SCM_I_ARRAY_V (ra2);
 437
 438   scm_array_get_handle (ra0, &ra0_handle);
 439   ra0_dims = scm_array_handle_dims (&ra0_handle);
 440   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 441   inc0 = ra0_dims[0].inc;
 442
 443   {
 444     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 445       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 446         if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
 447           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 448   }
 449
 450   scm_array_handle_release (&ra0_handle);
 451   return 1;
 452 }
 453
 454 /* opt 0 means <, nonzero means >= */
 455
 456 static int
 457 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
 458 {
 459   scm_t_array_handle ra0_handle;
 460   scm_t_array_dim *ra0_dims;
 461   size_t n;
 462   ssize_t inc0;
 463   size_t i0 = 0;
 464   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 465   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 466   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 467   ra1 = SCM_I_ARRAY_V (ra1);
 468   ra2 = SCM_I_ARRAY_V (ra2);
 469
 470   scm_array_get_handle (ra0, &ra0_handle);
 471   ra0_dims = scm_array_handle_dims (&ra0_handle);
 472   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 473   inc0 = ra0_dims[0].inc;
 474
 475   {
 476     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 477       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 478         if (opt ?
 479             scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
 480             scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
 481           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 482   }
 483
 484   scm_array_handle_release (&ra0_handle);
 485   return 1;
 486 }
 487
 488
 489
 490 int
 491 scm_ra_lessp (SCM ra0, SCM ras)
 492 {
 493   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
 494 }
 495
 496
 497 int
 498 scm_ra_leqp (SCM ra0, SCM ras)
 499 {
 500   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
 501 }
 502
 503
 504 int
 505 scm_ra_grp (SCM ra0, SCM ras)
 506 {
 507   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
 508 }
 509
 510
 511 int
 512 scm_ra_greqp (SCM ra0, SCM ras)
 513 {
 514   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
 515 }
 516
 517
 518 int
 519 scm_ra_sum (SCM ra0, SCM ras)
 520 {
 521   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 522   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 523   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 524   ra0 = SCM_I_ARRAY_V (ra0);
 525   if (!scm_is_null(ras))
 526     {
 527       SCM ra1 = SCM_CAR (ras);
 528       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 529       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 530       ra1 = SCM_I_ARRAY_V (ra1);
 531       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 532         {
 533         default:
 534           {
 535             for (; n-- > 0; i0 += inc0, i1 += inc1)
 536               ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
 537             break;
 538           }
 539         }
 540     }
 541   return 1;
 542 }
 543
 544
 545
 546 int
 547 scm_ra_difference (SCM ra0, SCM ras)
 548 {
 549   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 550   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 551   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 552   ra0 = SCM_I_ARRAY_V (ra0);
 553   if (scm_is_null (ras))
 554     {
 555       switch (SCM_TYP7 (ra0))
 556         {
 557         default:
 558           {
 559             for (; n-- > 0; i0 += inc0)
 560               ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
 561             break;
 562           }
 563         }
 564     }
 565   else
 566     {
 567       SCM ra1 = SCM_CAR (ras);
 568       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 569       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 570       ra1 = SCM_I_ARRAY_V (ra1);
 571       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 572         {
 573         default:
 574           {
 575             for (; n-- > 0; i0 += inc0, i1 += inc1)
 576               ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
 577             break;
 578           }
 579         }
 580     }
 581   return 1;
 582 }
 583
 584
 585
 586 int
 587 scm_ra_product (SCM ra0, SCM ras)
 588 {
 589   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 590   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 591   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 592   ra0 = SCM_I_ARRAY_V (ra0);
 593   if (!scm_is_null (ras))
 594     {
 595       SCM ra1 = SCM_CAR (ras);
 596       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 597       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 598       ra1 = SCM_I_ARRAY_V (ra1);
 599       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 600         {
 601         default:
 602           {
 603             for (; n-- > 0; i0 += inc0, i1 += inc1)
 604               ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
 605           }
 606         }
 607     }
 608   return 1;
 609 }
 610
 611
 612 int
 613 scm_ra_divide (SCM ra0, SCM ras)
 614 {
 615   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 616   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 617   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 618   ra0 = SCM_I_ARRAY_V (ra0);
 619   if (scm_is_null (ras))
 620     {
 621       switch (SCM_TYP7 (ra0))
 622         {
 623         default:
 624           {
 625             for (; n-- > 0; i0 += inc0)
 626               ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
 627             break;
 628           }
 629         }
 630     }
 631   else
 632     {
 633       SCM ra1 = SCM_CAR (ras);
 634       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 635       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 636       ra1 = SCM_I_ARRAY_V (ra1);
 637       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 638         {
 639         default:
 640           {
 641             for (; n-- > 0; i0 += inc0, i1 += inc1)
 642               {
 643                 SCM res =  scm_divide (AREF (ra0, i0), AREF (ra1, i1));
 644                 ASET (ra0, i0, res);
 645               }
 646             break;
 647           }
 648         }
 649     }
 650   return 1;
 651 }
 652
 653
 654 int
 655 scm_array_identity (SCM dst, SCM src)
 656 {
 657   return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
 658 }
 659
 660 #endif /* SCM_ENABLE_DEPRECATED */
 661
 662 static int
 663 ramap (SCM ra0, SCM proc, SCM ras)
 664 {
 665   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 666   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 667
 668   scm_t_array_handle h0;
 669   size_t i0, i0end;
 670   ssize_t inc0;
 671   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 672   i0 = SCM_I_ARRAY_BASE (ra0);
 673   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 674   i0end = i0 + n*inc0;
 675   if (scm_is_null (ras))
 676     for (; i0 < i0end; i0 += inc0)
 677       h0.impl->vset (&h0, i0, scm_call_0 (proc));
 678   else
 679     {
 680       SCM ra1 = SCM_CAR (ras);
 681       scm_t_array_handle h1;
 682       size_t i1;
 683       ssize_t inc1;
 684       scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
 685       i1 = SCM_I_ARRAY_BASE (ra1);
 686       inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 687       ras = SCM_CDR (ras);
 688       if (scm_is_null (ras))
 689           for (; i0 < i0end; i0 += inc0, i1 += inc1)
 690             h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
 691       else
 692         {
 693           ras = scm_vector (ras);
 694           for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
 695             {
 696               SCM args = SCM_EOL;
 697               unsigned long k;
 698               for (k = scm_c_vector_length (ras); k--;)
 699                 args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
 700               h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
 701             }
 702         }
 703       scm_array_handle_release (&h1);
 704     }
 705   scm_array_handle_release (&h0);
 706   return 1;
 707 }
 708
 709
 710 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
 711
 712 SCM_SYMBOL (sym_b, "b");
 713
 714 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 715             (SCM ra0, SCM proc, SCM lra),
 716             "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
 717             "@var{array1}, @dots{} must have the same number of dimensions\n"
 718             "as @var{ra0} and have a range for each index which includes the\n"
 719             "range for the corresponding index in @var{ra0}.  @var{proc} is\n"
 720             "applied to each tuple of elements of @var{array1}, @dots{} and\n"
 721             "the result is stored as the corresponding element in @var{ra0}.\n"
 722             "The value returned is unspecified.  The order of application is\n"
 723             "unspecified.")
 724 #define FUNC_NAME s_scm_array_map_x
 725 {
 726   SCM_VALIDATE_PROC (2, proc);
 727   SCM_VALIDATE_REST_ARGUMENT (lra);
 728
 729   scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
 730   return SCM_UNSPECIFIED;
 731 }
 732 #undef FUNC_NAME
 733
 734
 735 static int
 736 rafe (SCM ra0, SCM proc, SCM ras)
 737 {
 738   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 739   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 740
 741   scm_t_array_handle h0;
 742   size_t i0, i0end;
 743   ssize_t inc0;
 744   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 745   i0 = SCM_I_ARRAY_BASE (ra0);
 746   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 747   i0end = i0 + n*inc0;
 748   if (scm_is_null (ras))
 749     for (; i0 < i0end; i0 += inc0)
 750       scm_call_1 (proc, h0.impl->vref (&h0, i0));
 751   else
 752     {
 753       ras = scm_vector (ras);
 754       for (; i0 < i0end; i0 += inc0, ++i)
 755         {
 756           SCM args = SCM_EOL;
 757           unsigned long k;
 758           for (k = scm_c_vector_length (ras); k--;)
 759             args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
 760           scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
 761         }
 762     }
 763   scm_array_handle_release (&h0);
 764   return 1;
 765 }
 766
 767 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 768             (SCM proc, SCM ra0, SCM lra),
 769             "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
 770             "in row-major order.  The value returned is unspecified.")
 771 #define FUNC_NAME s_scm_array_for_each
 772 {
 773   SCM_VALIDATE_PROC (1, proc);
 774   SCM_VALIDATE_REST_ARGUMENT (lra);
 775   scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
 776   return SCM_UNSPECIFIED;
 777 }
 778 #undef FUNC_NAME
 779
 780 static void
 781 array_index_map_1 (SCM ra, SCM proc)
 782 {
 783   scm_t_array_handle h;
 784   ssize_t i, inc;
 785   size_t p;
 786   SCM v;
 787   scm_array_get_handle (ra, &h);
 788   v = h.array;
 789   inc = h.dims[0].inc;
 790   for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
 791     h.impl->vset (&h, p, scm_call_1 (proc, scm_from_ulong (i)));
 792   scm_array_handle_release (&h);
 793 }
 794
 795 /* Here we assume that the array is a scm_tc7_array, as that is the only
 796    kind of array in Guile that supports rank > 1.  */
 797 static void
 798 array_index_map_n (SCM ra, SCM proc)
 799 {
 800   size_t i;
 801   SCM args = SCM_EOL;
 802   int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
 803   long *vinds;
 804
 805   vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
 806                                      indices_gc_hint);
 807
 808   for (k = 0; k <= kmax; k++)
 809     vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 810   k = kmax;
 811   do
 812     {
 813       if (k == kmax)
 814         {
 815           vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 816           i = cind (ra, vinds);
 817           for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
 818             {
 819               for (j = kmax + 1, args = SCM_EOL; j--;)
 820                 args = scm_cons (scm_from_long (vinds[j]), args);
 821               ASET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
 822               i += SCM_I_ARRAY_DIMS (ra)[k].inc;
 823             }
 824           k--;
 825           continue;
 826         }
 827       if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
 828         {
 829           vinds[k]++;
 830           k++;
 831           continue;
 832         }
 833       vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
 834       k--;
 835     }
 836   while (k >= 0);
 837 }
 838
 839 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
 840             (SCM ra, SCM proc),
 841             "Apply @var{proc} to the indices of each element of @var{ra} in\n"
 842             "turn, storing the result in the corresponding element.  The value\n"
 843             "returned and the order of application are unspecified.\n\n"
 844             "One can implement @var{array-indexes} as\n"
 845             "@lisp\n"
 846             "(define (array-indexes array)\n"
 847             "    (let ((ra (apply make-array #f (array-shape array))))\n"
 848             "      (array-index-map! ra (lambda x x))\n"
 849             "      ra))\n"
 850             "@end lisp\n"
 851             "Another example:\n"
 852             "@lisp\n"
 853             "(define (apl:index-generator n)\n"
 854             "    (let ((v (make-uniform-vector n 1)))\n"
 855             "      (array-index-map! v (lambda (i) i))\n"
 856             "      v))\n"
 857             "@end lisp")
 858 #define FUNC_NAME s_scm_array_index_map_x
 859 {
 860   SCM_VALIDATE_PROC (2, proc);
 861
 862   switch (scm_c_array_rank (ra))
 863     {
 864     case 0:
 865       scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
 866       break;
 867     case 1:
 868       array_index_map_1 (ra, proc);
 869       break;
 870     default:
 871       array_index_map_n (ra, proc);
 872       break;
 873     }
 874
 875   return SCM_UNSPECIFIED;
 876 }
 877 #undef FUNC_NAME
 878
 879
 880 static int
 881 array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
 882                size_t dim, unsigned long posx, unsigned long posy)
 883 {
 884   if (dim == scm_array_handle_rank (hx))
 885     return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
 886                                      scm_array_handle_ref (hy, posy)));
 887   else
 888     {
 889       long incx, incy;
 890       size_t i;
 891
 892       if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
 893           || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
 894         return 0;
 895
 896       i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
 897
 898       incx = hx->dims[dim].inc;
 899       incy = hy->dims[dim].inc;
 900       posx += (i - 1) * incx;
 901       posy += (i - 1) * incy;
 902
 903       for (; i > 0; i--, posx -= incx, posy -= incy)
 904         if (!array_compare (hx, hy, dim + 1, posx, posy))
 905           return 0;
 906       return 1;
 907     }
 908 }
 909
 910 SCM
 911 scm_array_equal_p (SCM x, SCM y)
 912 {
 913   scm_t_array_handle hx, hy;
 914   SCM res;
 915
 916   scm_array_get_handle (x, &hx);
 917   scm_array_get_handle (y, &hy);
 918
 919   res = scm_from_bool (hx.ndims == hy.ndims
 920                        && hx.element_type == hy.element_type);
 921
 922   if (scm_is_true (res))
 923     res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
 924
 925   scm_array_handle_release (&hy);
 926   scm_array_handle_release (&hx);
 927
 928   return res;
 929 }
 930
 931 static SCM scm_i_array_equal_p (SCM, SCM, SCM);
 932 SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
 933             (SCM ra0, SCM ra1, SCM rest),
 934             "Return @code{#t} iff all arguments are arrays with the same\n"
 935             "shape, the same type, and have corresponding elements which are\n"
 936             "either @code{equal?}  or @code{array-equal?}.  This function\n"
 937             "differs from @code{equal?} in that all arguments must be arrays.")
 938 #define FUNC_NAME s_scm_i_array_equal_p
 939 {
 940   if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
 941     return SCM_BOOL_T;
 942
 943   while (!scm_is_null (rest))
 944     { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
 945         return SCM_BOOL_F;
 946       ra0 = ra1;
 947       ra1 = scm_car (rest);
 948       rest = scm_cdr (rest);
 949     }
 950   return scm_array_equal_p (ra0, ra1);
 951 }
 952 #undef FUNC_NAME
 953
 954
 955 void
 956 scm_init_array_map (void)
 957 {
 958 #include "libguile/array-map.x"
 959   scm_add_feature (s_scm_array_for_each);
 960 }
 961
 962 /*
 963   Local Variables:
 964   c-file-style: "gnu"
 965   End:
 966 */