libguile/array-map.c

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