libguile/array-map.c

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