libguile/array-map.c

   1 /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
   2  *   2010, 2011, 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_is_pair (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_is_pair (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_is_pair (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_is_pair (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_array_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
 351 static int
 352 racp (SCM src, SCM dst)
 353 {
 354   long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
 355   scm_t_array_handle h_s, h_d;
 356   size_t i_s, i_d;
 357   ssize_t inc_s, inc_d;
 358
 359   dst = SCM_CAR (dst);
 360   scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
 361   scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
 362
 363   i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
 364   i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
 365   inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
 366   inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
 367
 368   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
 369     h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
 370
 371   scm_array_handle_release (&h_d);
 372   scm_array_handle_release (&h_s);
 373
 374   return 1;
 375 }
 376
 377 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
 378
 379
 380 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 381             (SCM src, SCM dst),
 382             "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
 383             "Copy every element from vector or array @var{src} to the\n"
 384             "corresponding element of @var{dst}.  @var{dst} must have the\n"
 385             "same rank as @var{src}, and be at least as large in each\n"
 386             "dimension.  The order is unspecified.")
 387 #define FUNC_NAME s_scm_array_copy_x
 388 {
 389   scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
 390   return SCM_UNSPECIFIED;
 391 }
 392 #undef FUNC_NAME
 393
 394
 395 #if SCM_ENABLE_DEPRECATED == 1
 396
 397 /* to be used as cproc in scm_ramapc to fill an array dimension with
 398    "fill". */
 399 int
 400 scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
 401 {
 402   unsigned long i;
 403   unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
 404   long inc = SCM_I_ARRAY_DIMS (ra)->inc;
 405   unsigned long base = SCM_I_ARRAY_BASE (ra);
 406
 407   ra = SCM_I_ARRAY_V (ra);
 408
 409   for (i = base; n--; i += inc)
 410     GVSET (ra, i, fill);
 411
 412   return 1;
 413 }
 414
 415 /* Functions callable by ARRAY-MAP! */
 416
 417 int
 418 scm_ra_eqp (SCM ra0, SCM ras)
 419 {
 420   SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
 421   scm_t_array_handle ra0_handle;
 422   scm_t_array_dim *ra0_dims;
 423   size_t n;
 424   ssize_t inc0;
 425   size_t i0 = 0;
 426   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 427   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 428   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 429   ra1 = SCM_I_ARRAY_V (ra1);
 430   ra2 = SCM_I_ARRAY_V (ra2);
 431
 432   scm_array_get_handle (ra0, &ra0_handle);
 433   ra0_dims = scm_array_handle_dims (&ra0_handle);
 434   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 435   inc0 = ra0_dims[0].inc;
 436
 437   {
 438     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 439       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 440         if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
 441           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 442   }
 443
 444   scm_array_handle_release (&ra0_handle);
 445   return 1;
 446 }
 447
 448 /* opt 0 means <, nonzero means >= */
 449
 450 static int
 451 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
 452 {
 453   scm_t_array_handle ra0_handle;
 454   scm_t_array_dim *ra0_dims;
 455   size_t n;
 456   ssize_t inc0;
 457   size_t i0 = 0;
 458   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 459   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 460   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 461   ra1 = SCM_I_ARRAY_V (ra1);
 462   ra2 = SCM_I_ARRAY_V (ra2);
 463
 464   scm_array_get_handle (ra0, &ra0_handle);
 465   ra0_dims = scm_array_handle_dims (&ra0_handle);
 466   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 467   inc0 = ra0_dims[0].inc;
 468
 469   {
 470     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 471       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 472         if (opt ?
 473             scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
 474             scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
 475           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 476   }
 477
 478   scm_array_handle_release (&ra0_handle);
 479   return 1;
 480 }
 481
 482
 483
 484 int
 485 scm_ra_lessp (SCM ra0, SCM ras)
 486 {
 487   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
 488 }
 489
 490
 491 int
 492 scm_ra_leqp (SCM ra0, SCM ras)
 493 {
 494   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
 495 }
 496
 497
 498 int
 499 scm_ra_grp (SCM ra0, SCM ras)
 500 {
 501   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
 502 }
 503
 504
 505 int
 506 scm_ra_greqp (SCM ra0, SCM ras)
 507 {
 508   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
 509 }
 510
 511
 512 int
 513 scm_ra_sum (SCM ra0, SCM ras)
 514 {
 515   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 516   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 517   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 518   ra0 = SCM_I_ARRAY_V (ra0);
 519   if (!scm_is_null(ras))
 520     {
 521       SCM ra1 = SCM_CAR (ras);
 522       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 523       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 524       ra1 = SCM_I_ARRAY_V (ra1);
 525       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 526         {
 527         default:
 528           {
 529             for (; n-- > 0; i0 += inc0, i1 += inc1)
 530               GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
 531             break;
 532           }
 533         }
 534     }
 535   return 1;
 536 }
 537
 538
 539
 540 int
 541 scm_ra_difference (SCM ra0, SCM ras)
 542 {
 543   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 544   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 545   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 546   ra0 = SCM_I_ARRAY_V (ra0);
 547   if (scm_is_null (ras))
 548     {
 549       switch (SCM_TYP7 (ra0))
 550         {
 551         default:
 552           {
 553             for (; n-- > 0; i0 += inc0)
 554               GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
 555             break;
 556           }
 557         }
 558     }
 559   else
 560     {
 561       SCM ra1 = SCM_CAR (ras);
 562       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 563       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 564       ra1 = SCM_I_ARRAY_V (ra1);
 565       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 566         {
 567         default:
 568           {
 569             for (; n-- > 0; i0 += inc0, i1 += inc1)
 570               GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
 571                                               GVREF (ra1, i1)));
 572             break;
 573           }
 574         }
 575     }
 576   return 1;
 577 }
 578
 579
 580
 581 int
 582 scm_ra_product (SCM ra0, SCM ras)
 583 {
 584   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 585   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 586   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 587   ra0 = SCM_I_ARRAY_V (ra0);
 588   if (!scm_is_null (ras))
 589     {
 590       SCM ra1 = SCM_CAR (ras);
 591       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 592       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 593       ra1 = SCM_I_ARRAY_V (ra1);
 594       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 595         {
 596         default:
 597           {
 598             for (; n-- > 0; i0 += inc0, i1 += inc1)
 599               GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
 600                                            GVREF (ra1, i1)));
 601           }
 602         }
 603     }
 604   return 1;
 605 }
 606
 607
 608 int
 609 scm_ra_divide (SCM ra0, SCM ras)
 610 {
 611   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 612   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 613   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 614   ra0 = SCM_I_ARRAY_V (ra0);
 615   if (scm_is_null (ras))
 616     {
 617       switch (SCM_TYP7 (ra0))
 618         {
 619         default:
 620           {
 621             for (; n-- > 0; i0 += inc0)
 622               GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
 623             break;
 624           }
 625         }
 626     }
 627   else
 628     {
 629       SCM ra1 = SCM_CAR (ras);
 630       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 631       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 632       ra1 = SCM_I_ARRAY_V (ra1);
 633       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 634         {
 635         default:
 636           {
 637             for (; n-- > 0; i0 += inc0, i1 += inc1)
 638               {
 639                 SCM res =  scm_divide (GVREF (ra0, i0),
 640                                        GVREF (ra1, i1));
 641                 GVSET (ra0, i0, res);
 642               }
 643             break;
 644           }
 645         }
 646     }
 647   return 1;
 648 }
 649
 650
 651 int
 652 scm_array_identity (SCM dst, SCM src)
 653 {
 654   return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
 655 }
 656
 657 #endif /* SCM_ENABLE_DEPRECATED */
 658
 659 static int
 660 ramap (SCM ra0, SCM proc, SCM ras)
 661 {
 662   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 663   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 664
 665   scm_t_array_handle h0;
 666   size_t i0, i0end;
 667   ssize_t inc0;
 668   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 669   i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
 670   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
 671   i0end = i0 + n*inc0;
 672   if (scm_is_null (ras))
 673     for (; i0 < i0end; i0 += inc0)
 674       h0.impl->vset (&h0, i0, scm_call_0 (proc));
 675   else
 676     {
 677       SCM ra1 = SCM_CAR (ras);
 678       scm_t_array_handle h1;
 679       size_t i1;
 680       ssize_t inc1;
 681       scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
 682       i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
 683       inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
 684       ras = SCM_CDR (ras);
 685       if (scm_is_null (ras))
 686           for (; i0 < i0end; i0 += inc0, i1 += inc1)
 687             h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
 688       else
 689         {
 690           ras = scm_vector (ras);
 691           for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
 692             {
 693               SCM args = SCM_EOL;
 694               unsigned long k;
 695               for (k = scm_c_vector_length (ras); k--;)
 696                 args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
 697               h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
 698             }
 699         }
 700       scm_array_handle_release (&h1);
 701     }
 702   scm_array_handle_release (&h0);
 703   return 1;
 704 }
 705
 706
 707 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
 708
 709 SCM_SYMBOL (sym_b, "b");
 710
 711 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 712             (SCM ra0, SCM proc, SCM lra),
 713             "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
 714             "@var{array1}, @dots{} must have the same number of dimensions\n"
 715             "as @var{ra0} and have a range for each index which includes the\n"
 716             "range for the corresponding index in @var{ra0}.  @var{proc} is\n"
 717             "applied to each tuple of elements of @var{array1}, @dots{} and\n"
 718             "the result is stored as the corresponding element in @var{ra0}.\n"
 719             "The value returned is unspecified.  The order of application is\n"
 720             "unspecified.")
 721 #define FUNC_NAME s_scm_array_map_x
 722 {
 723   SCM_VALIDATE_PROC (2, proc);
 724   SCM_VALIDATE_REST_ARGUMENT (lra);
 725
 726   scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
 727   return SCM_UNSPECIFIED;
 728 }
 729 #undef FUNC_NAME
 730
 731
 732 static int
 733 rafe (SCM ra0, SCM proc, SCM ras)
 734 {
 735   ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 736   size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
 737
 738   scm_t_array_handle h0;
 739   size_t i0, i0end;
 740   ssize_t inc0;
 741   scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
 742   i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
 743   inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
 744   i0end = i0 + n*inc0;
 745   if (scm_is_null (ras))
 746     for (; i0 < i0end; i0 += inc0)
 747       scm_call_1 (proc, h0.impl->vref (&h0, i0));
 748   else
 749     {
 750       ras = scm_vector (ras);
 751       for (; i0 < i0end; i0 += inc0, ++i)
 752         {
 753           SCM args = SCM_EOL;
 754           unsigned long k;
 755           for (k = scm_c_vector_length (ras); k--;)
 756             args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
 757           scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
 758         }
 759     }
 760   scm_array_handle_release (&h0);
 761   return 1;
 762 }
 763
 764 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 765             (SCM proc, SCM ra0, SCM lra),
 766             "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"
 767             "in row-major order.  The value returned is unspecified.")
 768 #define FUNC_NAME s_scm_array_for_each
 769 {
 770   SCM_VALIDATE_PROC (1, proc);
 771   SCM_VALIDATE_REST_ARGUMENT (lra);
 772   scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
 773   return SCM_UNSPECIFIED;
 774 }
 775 #undef FUNC_NAME
 776
 777 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
 778             (SCM ra, SCM proc),
 779             "Apply @var{proc} to the indices of each element of @var{ra} in\n"
 780             "turn, storing the result in the corresponding element.  The value\n"
 781             "returned and the order of application are unspecified.\n\n"
 782             "One can implement @var{array-indexes} as\n"
 783             "@lisp\n"
 784             "(define (array-indexes array)\n"
 785             "    (let ((ra (apply make-array #f (array-shape array))))\n"
 786             "      (array-index-map! ra (lambda x x))\n"
 787             "      ra))\n"
 788             "@end lisp\n"
 789             "Another example:\n"
 790             "@lisp\n"
 791             "(define (apl:index-generator n)\n"
 792             "    (let ((v (make-uniform-vector n 1)))\n"
 793             "      (array-index-map! v (lambda (i) i))\n"
 794             "      v))\n"
 795             "@end lisp")
 796 #define FUNC_NAME s_scm_array_index_map_x
 797 {
 798   unsigned long i;
 799   SCM_VALIDATE_PROC (2, proc);
 800
 801   if (SCM_I_ARRAYP (ra))
 802     {
 803       SCM args = SCM_EOL;
 804       int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
 805       long *vinds;
 806
 807       if (kmax < 0)
 808         return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
 809
 810       vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
 811                                          indices_gc_hint);
 812
 813       for (k = 0; k <= kmax; k++)
 814         vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 815       k = kmax;
 816       do
 817         {
 818           if (k == kmax)
 819             {
 820               vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
 821               i = cind (ra, vinds);
 822               for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
 823                 {
 824                   for (j = kmax + 1, args = SCM_EOL; j--;)
 825                     args = scm_cons (scm_from_long (vinds[j]), args);
 826                   GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
 827                   i += SCM_I_ARRAY_DIMS (ra)[k].inc;
 828                 }
 829               k--;
 830               continue;
 831             }
 832           if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
 833             {
 834               vinds[k]++;
 835               k++;
 836               continue;
 837             }
 838           vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
 839           k--;
 840         }
 841       while (k >= 0);
 842
 843       return SCM_UNSPECIFIED;
 844     }
 845   else if (scm_is_generalized_vector (ra))
 846     {
 847       size_t length = scm_c_generalized_vector_length (ra);
 848       for (i = 0; i < length; i++)
 849         GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
 850       return SCM_UNSPECIFIED;
 851     }
 852   else
 853     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 854 }
 855 #undef FUNC_NAME
 856
 857
 858 static int
 859 array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
 860                size_t dim, unsigned long posx, unsigned long posy)
 861 {
 862   if (dim == scm_array_handle_rank (hx))
 863     return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
 864                                      scm_array_handle_ref (hy, posy)));
 865   else
 866     {
 867       long incx, incy;
 868       size_t i;
 869
 870       if (hx->dims[dim].lbnd != hy->dims[dim].lbnd
 871           || hx->dims[dim].ubnd != hy->dims[dim].ubnd)
 872         return 0;
 873
 874       i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
 875
 876       incx = hx->dims[dim].inc;
 877       incy = hy->dims[dim].inc;
 878       posx += (i - 1) * incx;
 879       posy += (i - 1) * incy;
 880
 881       for (; i > 0; i--, posx -= incx, posy -= incy)
 882         if (!array_compare (hx, hy, dim + 1, posx, posy))
 883           return 0;
 884       return 1;
 885     }
 886 }
 887
 888 SCM
 889 scm_array_equal_p (SCM x, SCM y)
 890 {
 891   scm_t_array_handle hx, hy;
 892   SCM res;
 893
 894   scm_array_get_handle (x, &hx);
 895   scm_array_get_handle (y, &hy);
 896
 897   res = scm_from_bool (hx.ndims == hy.ndims
 898                        && hx.element_type == hy.element_type);
 899
 900   if (scm_is_true (res))
 901     res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0));
 902
 903   scm_array_handle_release (&hy);
 904   scm_array_handle_release (&hx);
 905
 906   return res;
 907 }
 908
 909 static SCM scm_i_array_equal_p (SCM, SCM, SCM);
 910 SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
 911             (SCM ra0, SCM ra1, SCM rest),
 912             "Return @code{#t} iff all arguments are arrays with the same\n"
 913             "shape, the same type, and have corresponding elements which are\n"
 914             "either @code{equal?}  or @code{array-equal?}.  This function\n"
 915             "differs from @code{equal?} in that all arguments must be arrays.")
 916 #define FUNC_NAME s_scm_i_array_equal_p
 917 {
 918   if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
 919     return SCM_BOOL_T;
 920
 921   while (!scm_is_null (rest))
 922     { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
 923         return SCM_BOOL_F;
 924       ra0 = ra1;
 925       ra1 = scm_car (rest);
 926       rest = scm_cdr (rest);
 927     }
 928   return scm_array_equal_p (ra0, ra1);
 929 }
 930 #undef FUNC_NAME
 931
 932
 933 void
 934 scm_init_array_map (void)
 935 {
 936 #include "libguile/array-map.x"
 937   scm_add_feature (s_scm_array_for_each);
 938 }
 939
 940 /*
 941   Local Variables:
 942   c-file-style: "gnu"
 943   End:
 944 */