libguile/array-map.c

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