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) ();
 187
 188   cproc = cproc_ptr;
 189   switch (scm_ra_matchp (ra0, lra))
 190     {
 191     default:
 192     case 0:
 193       scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
 194     case 2:
 195     case 3:
 196     case 4:                     /* Try unrolling arrays */
 197       kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
 198       if (kmax < 0)
 199         goto gencase;
 200       vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
 201       if (SCM_IMP (vra0)) goto gencase;
 202       if (!SCM_I_ARRAYP (vra0))
 203         {
 204           size_t length = scm_c_array_length (vra0);
 205           vra1 = scm_i_make_array (1);
 206           SCM_I_ARRAY_BASE (vra1) = 0;
 207           SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
 208           SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
 209           SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 210           SCM_I_ARRAY_V (vra1) = vra0;
 211           vra0 = vra1;
 212         }
 213       lvra = SCM_EOL;
 214       plvra = &lvra;
 215       for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
 216         {
 217           ra1 = SCM_CAR (z);
 218           vra1 = scm_i_make_array (1);
 219           SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 220           SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 221           if (!SCM_I_ARRAYP (ra1))
 222             {
 223               SCM_I_ARRAY_BASE (vra1) = 0;
 224               SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 225               SCM_I_ARRAY_V (vra1) = ra1;
 226             }
 227           else if (!SCM_I_ARRAY_CONTP (ra1))
 228             goto gencase;
 229           else
 230             {
 231               SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
 232               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 233               SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 234             }
 235           *plvra = scm_cons (vra1, SCM_EOL);
 236           plvra = SCM_CDRLOC (*plvra);
 237         }
 238       return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
 239     case 1:
 240     gencase:                    /* Have to loop over all dimensions. */
 241       vra0 = scm_i_make_array (1);
 242     if (SCM_I_ARRAYP (ra0))
 243       {
 244         kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
 245         if (kmax < 0)
 246           {
 247             SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 248             SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
 249             SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 250           }
 251         else
 252           {
 253             SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
 254             SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
 255             SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
 256           }
 257         SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
 258         SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
 259       }
 260     else
 261       {
 262         size_t length = scm_c_array_length (ra0);
 263         kmax = 0;
 264         SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 265         SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
 266         SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 267         SCM_I_ARRAY_BASE (vra0) = 0;
 268         SCM_I_ARRAY_V (vra0) = ra0;
 269         ra0 = vra0;
 270       }
 271     lvra = SCM_EOL;
 272     plvra = &lvra;
 273     for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
 274       {
 275         ra1 = SCM_CAR (z);
 276         vra1 = scm_i_make_array (1);
 277         SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 278         SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 279         if (SCM_I_ARRAYP (ra1))
 280           {
 281             if (kmax >= 0)
 282               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 283             SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 284           }
 285         else
 286           {
 287             SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 288             SCM_I_ARRAY_V (vra1) = ra1;
 289           }
 290         *plvra = scm_cons (vra1, SCM_EOL);
 291         plvra = SCM_CDRLOC (*plvra);
 292       }
 293
 294     vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
 295                                        indices_gc_hint);
 296
 297     for (k = 0; k <= kmax; k++)
 298       vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
 299     k = kmax;
 300     do
 301       {
 302         if (k == kmax)
 303           {
 304             SCM y = lra;
 305             SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
 306             for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
 307               SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
 308             if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
 309               return 0;
 310             k--;
 311             continue;
 312           }
 313         if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
 314           {
 315             vinds[k]++;
 316             k++;
 317             continue;
 318           }
 319         vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
 320         k--;
 321       }
 322     while (k >= 0);
 323
 324     return 1;
 325     }
 326 }
 327
 328 static int
 329 rafill (SCM dst, SCM fill)
 330 {
 331   long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
 332   scm_t_array_handle h;
 333   size_t i;
 334   ssize_t inc;
 335   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
 336   i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
 337   inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
 338
 339   for (; n-- > 0; i += inc)
 340     h.impl->vset (&h, i, fill);
 341
 342   scm_array_handle_release (&h);
 343   return 1;
 344 }
 345
 346 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 347             (SCM ra, SCM fill),
 348             "Store @var{fill} in every element of array @var{ra}.  The value\n"
 349             "returned is unspecified.")
 350 #define FUNC_NAME s_scm_array_fill_x
 351 {
 352   scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
 353   return SCM_UNSPECIFIED;
 354 }
 355 #undef FUNC_NAME
 356
 357
 358 static int
 359 racp (SCM src, SCM dst)
 360 {
 361   long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
 362   scm_t_array_handle h_s, h_d;
 363   size_t i_s, i_d;
 364   ssize_t inc_s, inc_d;
 365
 366   dst = SCM_CAR (dst);
 367   scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
 368   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
 369
 370   i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
 371   i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
 372   inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
 373   inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
 374
 375   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
 376     h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
 377
 378   scm_array_handle_release (&h_d);
 379   scm_array_handle_release (&h_s);
 380
 381   return 1;
 382 }
 383
 384 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
 385
 386
 387 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 388             (SCM src, SCM dst),
 389             "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
 390             "Copy every element from vector or array @var{src} to the\n"
 391             "corresponding element of @var{dst}.  @var{dst} must have the\n"
 392             "same rank as @var{src}, and be at least as large in each\n"
 393             "dimension.  The order is unspecified.")
 394 #define FUNC_NAME s_scm_array_copy_x
 395 {
 396   scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
 397   return SCM_UNSPECIFIED;
 398 }
 399 #undef FUNC_NAME
 400
 401
 402 #if SCM_ENABLE_DEPRECATED == 1
 403
 404 /* to be used as cproc in scm_ramapc to fill an array dimension with
 405    "fill". */
 406 int
 407 scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
 408 {
 409   unsigned long i;
 410   unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
 411   long inc = SCM_I_ARRAY_DIMS (ra)->inc;
 412   unsigned long base = SCM_I_ARRAY_BASE (ra);
 413
 414   ra = SCM_I_ARRAY_V (ra);
 415
 416   for (i = base; n--; i += inc)
 417     ASET (ra, i, fill);
 418
 419   return 1;
 420 }
 421
 422 /* Functions callable by ARRAY-MAP! */
 423
 424 int
 425 scm_ra_eqp (SCM ra0, SCM ras)
 426 {
 427   SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
 428   scm_t_array_handle ra0_handle;
 429   scm_t_array_dim *ra0_dims;
 430   size_t n;
 431   ssize_t inc0;
 432   size_t i0 = 0;
 433   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 434   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 435   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 436   ra1 = SCM_I_ARRAY_V (ra1);
 437   ra2 = SCM_I_ARRAY_V (ra2);
 438
 439   scm_array_get_handle (ra0, &ra0_handle);
 440   ra0_dims = scm_array_handle_dims (&ra0_handle);
 441   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 442   inc0 = ra0_dims[0].inc;
 443
 444   {
 445     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 446       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 447         if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
 448           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 449   }
 450
 451   scm_array_handle_release (&ra0_handle);
 452   return 1;
 453 }
 454
 455 /* opt 0 means <, nonzero means >= */
 456
 457 static int
 458 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
 459 {
 460   scm_t_array_handle ra0_handle;
 461   scm_t_array_dim *ra0_dims;
 462   size_t n;
 463   ssize_t inc0;
 464   size_t i0 = 0;
 465   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 466   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 467   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 468   ra1 = SCM_I_ARRAY_V (ra1);
 469   ra2 = SCM_I_ARRAY_V (ra2);
 470
 471   scm_array_get_handle (ra0, &ra0_handle);
 472   ra0_dims = scm_array_handle_dims (&ra0_handle);
 473   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 474   inc0 = ra0_dims[0].inc;
 475
 476   {
 477     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 478       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 479         if (opt ?
 480             scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
 481             scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
 482           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 483   }
 484
 485   scm_array_handle_release (&ra0_handle);
 486   return 1;
 487 }
 488
 489
 490
 491 int
 492 scm_ra_lessp (SCM ra0, SCM ras)
 493 {
 494   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
 495 }
 496
 497
 498 int
 499 scm_ra_leqp (SCM ra0, SCM ras)
 500 {
 501   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
 502 }
 503
 504
 505 int
 506 scm_ra_grp (SCM ra0, SCM ras)
 507 {
 508   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
 509 }
 510
 511
 512 int
 513 scm_ra_greqp (SCM ra0, SCM ras)
 514 {
 515   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
 516 }
 517
 518
 519 int
 520 scm_ra_sum (SCM ra0, SCM ras)
 521 {
 522   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 523   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 524   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 525   ra0 = SCM_I_ARRAY_V (ra0);
 526   if (!scm_is_null(ras))
 527     {
 528       SCM ra1 = SCM_CAR (ras);
 529       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 530       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 531       ra1 = SCM_I_ARRAY_V (ra1);
 532       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 533         {
 534         default:
 535           {
 536             for (; n-- > 0; i0 += inc0, i1 += inc1)
 537               ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
 538             break;
 539           }
 540         }
 541     }
 542   return 1;
 543 }
 544
 545
 546
 547 int
 548 scm_ra_difference (SCM ra0, SCM ras)
 549 {
 550   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 551   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 552   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 553   ra0 = SCM_I_ARRAY_V (ra0);
 554   if (scm_is_null (ras))
 555     {
 556       switch (SCM_TYP7 (ra0))
 557         {
 558         default:
 559           {
 560             for (; n-- > 0; i0 += inc0)
 561               ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
 562             break;
 563           }
 564         }
 565     }
 566   else
 567     {
 568       SCM ra1 = SCM_CAR (ras);
 569       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 570       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 571       ra1 = SCM_I_ARRAY_V (ra1);
 572       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 573         {
 574         default:
 575           {
 576             for (; n-- > 0; i0 += inc0, i1 += inc1)
 577               ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
 578             break;
 579           }
 580         }
 581     }
 582   return 1;
 583 }
 584
 585
 586
 587 int
 588 scm_ra_product (SCM ra0, SCM ras)
 589 {
 590   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 591   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 592   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 593   ra0 = SCM_I_ARRAY_V (ra0);
 594   if (!scm_is_null (ras))
 595     {
 596       SCM ra1 = SCM_CAR (ras);
 597       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 598       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 599       ra1 = SCM_I_ARRAY_V (ra1);
 600       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 601         {
 602         default:
 603           {
 604             for (; n-- > 0; i0 += inc0, i1 += inc1)
 605               ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
 606           }
 607         }
 608     }
 609   return 1;
 610 }
 611
 612
 613 int
 614 scm_ra_divide (SCM ra0, SCM ras)
 615 {
 616   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 617   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 618   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 619   ra0 = SCM_I_ARRAY_V (ra0);
 620   if (scm_is_null (ras))
 621     {
 622       switch (SCM_TYP7 (ra0))
 623         {
 624         default:
 625           {
 626             for (; n-- > 0; i0 += inc0)
 627               ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
 628             break;
 629           }
 630         }
 631     }
 632   else
 633     {
 634       SCM ra1 = SCM_CAR (ras);
 635       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 636       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 637       ra1 = SCM_I_ARRAY_V (ra1);
 638       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 639         {
 640         default:
 641           {
 642             for (; n-- > 0; i0 += inc0, i1 += inc1)
 643               {
 644                 SCM res =  scm_divide (AREF (ra0, i0), AREF (ra1, i1));
 645                 ASET (ra0, i0, res);
 646               }
 647             break;
 648           }
 649         }
 650     }
 651   return 1;
 652 }
 653
 654
 655 int
 656 scm_array_identity (SCM dst, SCM src)
 657 {
 658   return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
 659 }
 660
 661 #endif /* SCM_ENABLE_DEPRECATED */
 662
 663 static int
 664 ramap (SCM ra0, SCM proc, SCM ras)
 665 {
 666   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 667   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 668
 669   scm_t_array_handle h0;
 670   size_t i0, i0end;
 671   ssize_t inc0;
 672   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 673   i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
 674   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
 675   i0end = i0 + n*inc0;
 676   if (scm_is_null (ras))
 677     for (; i0 < i0end; i0 += inc0)
 678       h0.impl->vset (&h0, i0, scm_call_0 (proc));
 679   else
 680     {
 681       SCM ra1 = SCM_CAR (ras);
 682       scm_t_array_handle h1;
 683       size_t i1;
 684       ssize_t inc1;
 685       scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
 686       i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
 687       inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
 688       ras = SCM_CDR (ras);
 689       if (scm_is_null (ras))
 690           for (; i0 < i0end; i0 += inc0, i1 += inc1)
 691             h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
 692       else
 693         {
 694           ras = scm_vector (ras);
 695           for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
 696             {
 697               SCM args = SCM_EOL;
 698               unsigned long k;
 699               for (k = scm_c_vector_length (ras); k--;)
 700                 args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
 701               h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
 702             }
 703         }
 704       scm_array_handle_release (&h1);
 705     }
 706   scm_array_handle_release (&h0);
 707   return 1;
 708 }
 709
 710
 711 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
 712
 713 SCM_SYMBOL (sym_b, "b");
 714
 715 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 716             (SCM ra0, SCM proc, SCM lra),
 717             "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
 718             "@var{array1}, @dots{} must have the same number of dimensions\n"
 719             "as @var{ra0} and have a range for each index which includes the\n"
 720             "range for the corresponding index in @var{ra0}.  @var{proc} is\n"
 721             "applied to each tuple of elements of @var{array1}, @dots{} and\n"
 722             "the result is stored as the corresponding element in @var{ra0}.\n"
 723             "The value returned is unspecified.  The order of application is\n"
 724             "unspecified.")
 725 #define FUNC_NAME s_scm_array_map_x
 726 {
 727   SCM_VALIDATE_PROC (2, proc);
 728   SCM_VALIDATE_REST_ARGUMENT (lra);
 729
 730   scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
 731   return SCM_UNSPECIFIED;
 732 }
 733 #undef FUNC_NAME
 734
 735
 736 static int
 737 rafe (SCM ra0, SCM proc, SCM ras)
 738 {
 739   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 740   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 741
 742   scm_t_array_handle h0;
 743   size_t i0, i0end;
 744   ssize_t inc0;
 745   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 746   i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
 747   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
 748   i0end = i0 + n*inc0;
 749   if (scm_is_null (ras))
 750     for (; i0 < i0end; i0 += inc0)
 751       scm_call_1 (proc, h0.impl->vref (&h0, i0));
 752   else
 753     {
 754       ras = scm_vector (ras);
 755       for (; i0 < i0end; i0 += inc0, ++i)
 756         {
 757           SCM args = SCM_EOL;
 758           unsigned long k;
 759           for (k = scm_c_vector_length (ras); k--;)
 760             args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
 761           scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
 762         }
 763     }
 764   scm_array_handle_release (&h0);
 765   return 1;
 766 }
 767
 768 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 769             (SCM proc, SCM ra0, SCM lra),
 770             "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
 771             "in row-major order.  The value returned is unspecified.")
 772 #define FUNC_NAME s_scm_array_for_each
 773 {
 774   SCM_VALIDATE_PROC (1, proc);
 775   SCM_VALIDATE_REST_ARGUMENT (lra);
 776   scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
 777   return SCM_UNSPECIFIED;
 778 }
 779 #undef FUNC_NAME
 780
 781 static void
 782 array_index_map_1 (SCM ra, SCM proc)
 783 {
 784   scm_t_array_handle h;
 785   ssize_t i, inc;
 786   size_t p;
 787   SCM v;
 788   scm_array_get_handle (ra, &h);
 789   v = h.array;
 790   inc = h.dims[0].inc;
 791   for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
 792     h.impl->vset (&h, p, scm_call_1 (proc, scm_from_ulong (i)));
 793   scm_array_handle_release (&h);
 794 }
 795
 796 /* Here we assume that the array is a scm_tc7_array, as that is the only
 797    kind of array in Guile that supports rank > 1.  */
 798 static void
 799 array_index_map_n (SCM ra, SCM proc)
 800 {
 801   size_t i;
 802   SCM args = SCM_EOL;
 803   int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
 804   long *vinds;
 805
 806   vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
 807                                      indices_gc_hint);
 808
 809   for (k = 0; k <= kmax; k++)
 810     vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 811   k = kmax;
 812   do
 813     {
 814       if (k == kmax)
 815         {
 816           vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 817           i = cind (ra, vinds);
 818           for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
 819             {
 820               for (j = kmax + 1, args = SCM_EOL; j--;)
 821                 args = scm_cons (scm_from_long (vinds[j]), args);
 822               ASET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
 823               i += SCM_I_ARRAY_DIMS (ra)[k].inc;
 824             }
 825           k--;
 826           continue;
 827         }
 828       if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
 829         {
 830           vinds[k]++;
 831           k++;
 832           continue;
 833         }
 834       vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
 835       k--;
 836     }
 837   while (k >= 0);
 838 }
 839
 840 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
 841             (SCM ra, SCM proc),
 842             "Apply @var{proc} to the indices of each element of @var{ra} in\n"
 843             "turn, storing the result in the corresponding element.  The value\n"
 844             "returned and the order of application are unspecified.\n\n"
 845             "One can implement @var{array-indexes} as\n"
 846             "@lisp\n"
 847             "(define (array-indexes array)\n"
 848             "    (let ((ra (apply make-array #f (array-shape array))))\n"
 849             "      (array-index-map! ra (lambda x x))\n"
 850             "      ra))\n"
 851             "@end lisp\n"
 852             "Another example:\n"
 853             "@lisp\n"
 854             "(define (apl:index-generator n)\n"
 855             "    (let ((v (make-uniform-vector n 1)))\n"
 856             "      (array-index-map! v (lambda (i) i))\n"
 857             "      v))\n"
 858             "@end lisp")
 859 #define FUNC_NAME s_scm_array_index_map_x
 860 {
 861   SCM_VALIDATE_PROC (2, proc);
 862
 863   switch (scm_c_array_rank (ra))
 864     {
 865     case 0:
 866       scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
 867       break;
 868     case 1:
 869       array_index_map_1 (ra, proc);
 870       break;
 871     default:
 872       array_index_map_n (ra, proc);
 873       break;
 874     }
 875
 876   return SCM_UNSPECIFIED;
 877 }
 878 #undef FUNC_NAME
 879
 880
 881 static int
 882 array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
 883                size_t dim, unsigned long posx, unsigned long posy)
 884 {
 885   if (dim == scm_array_handle_rank (hx))
 886     return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
 887                                      scm_array_handle_ref (hy, posy)));
 888   else
 889     {
 890       long incx, incy;
 891       size_t i;
 892
 893       if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
 894           || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
 895         return 0;
 896
 897       i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
 898
 899       incx = hx->dims[dim].inc;
 900       incy = hy->dims[dim].inc;
 901       posx += (i - 1) * incx;
 902       posy += (i - 1) * incy;
 903
 904       for (; i > 0; i--, posx -= incx, posy -= incy)
 905         if (!array_compare (hx, hy, dim + 1, posx, posy))
 906           return 0;
 907       return 1;
 908     }
 909 }
 910
 911 SCM
 912 scm_array_equal_p (SCM x, SCM y)
 913 {
 914   scm_t_array_handle hx, hy;
 915   SCM res;
 916
 917   scm_array_get_handle (x, &hx);
 918   scm_array_get_handle (y, &hy);
 919
 920   res = scm_from_bool (hx.ndims == hy.ndims
 921                        && hx.element_type == hy.element_type);
 922
 923   if (scm_is_true (res))
 924     res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
 925
 926   scm_array_handle_release (&hy);
 927   scm_array_handle_release (&hx);
 928
 929   return res;
 930 }
 931
 932 static SCM scm_i_array_equal_p (SCM, SCM, SCM);
 933 SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
 934             (SCM ra0, SCM ra1, SCM rest),
 935             "Return @code{#t} iff all arguments are arrays with the same\n"
 936             "shape, the same type, and have corresponding elements which are\n"
 937             "either @code{equal?}  or @code{array-equal?}.  This function\n"
 938             "differs from @code{equal?} in that all arguments must be arrays.")
 939 #define FUNC_NAME s_scm_i_array_equal_p
 940 {
 941   if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
 942     return SCM_BOOL_T;
 943
 944   while (!scm_is_null (rest))
 945     { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
 946         return SCM_BOOL_F;
 947       ra0 = ra1;
 948       ra1 = scm_car (rest);
 949       rest = scm_cdr (rest);
 950     }
 951   return scm_array_equal_p (ra0, ra1);
 952 }
 953 #undef FUNC_NAME
 954
 955
 956 void
 957 scm_init_array_map (void)
 958 {
 959 #include "libguile/array-map.x"
 960   scm_add_feature (s_scm_array_for_each);
 961 }
 962
 963 /*
 964   Local Variables:
 965   c-file-style: "gnu"
 966   End:
 967 */