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