libguile/ramap.c

   1 /* Copyright (C) 1996,1998,2000,2001,2004,2005 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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 02110-1301 USA
  16  */
  17
  18
  19 /*
  20   HWN:FIXME::
  21   Someone should rename this to arraymap.c; that would reflect the
  22   contents better.  */
  23 \f
  24
  25
  26 \f
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/strings.h"
  30 #include "libguile/unif.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/srfi-4.h"
  39 #include "libguile/dynwind.h"
  40
  41 #include "libguile/validate.h"
  42 #include "libguile/ramap.h"
  43 \f
  44
  45 typedef struct
  46 {
  47   char *name;
  48   SCM sproc;
  49   int (*vproc) ();
  50 } ra_iproc;
  51
  52
  53 /* These tables are a kluge that will not scale well when more
  54  * vectorized subrs are added.  It is tempting to steal some bits from
  55  * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
  56  * offset into a table of vectorized subrs.
  57  */
  58
  59 static ra_iproc ra_rpsubrs[] =
  60 {
  61   {"=", SCM_UNDEFINED, scm_ra_eqp},
  62   {"<", SCM_UNDEFINED, scm_ra_lessp},
  63   {"<=", SCM_UNDEFINED, scm_ra_leqp},
  64   {">", SCM_UNDEFINED, scm_ra_grp},
  65   {">=", SCM_UNDEFINED, scm_ra_greqp},
  66   {0, 0, 0}
  67 };
  68
  69 static ra_iproc ra_asubrs[] =
  70 {
  71   {"+", SCM_UNDEFINED, scm_ra_sum},
  72   {"-", SCM_UNDEFINED, scm_ra_difference},
  73   {"*", SCM_UNDEFINED, scm_ra_product},
  74   {"/", SCM_UNDEFINED, scm_ra_divide},
  75   {0, 0, 0}
  76 };
  77
  78
  79 #define GVREF scm_c_generalized_vector_ref
  80 #define GVSET scm_c_generalized_vector_set_x
  81
  82 static unsigned long
  83 cind (SCM ra, long *ve)
  84 {
  85   unsigned long i;
  86   int k;
  87   if (!SCM_I_ARRAYP (ra))
  88     return *ve;
  89   i = SCM_I_ARRAY_BASE (ra);
  90   for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
  91     i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
  92   return i;
  93 }
  94
  95
  96 /* Checker for scm_array mapping functions:
  97    return values: 4 --> shapes, increments, and bases are the same;
  98    3 --> shapes and increments are the same;
  99    2 --> shapes are the same;
 100    1 --> ras are at least as big as ra0;
 101    0 --> no match.
 102    */
 103
 104 int
 105 scm_ra_matchp (SCM ra0, SCM ras)
 106 {
 107   SCM ra1;
 108   scm_t_array_dim dims;
 109   scm_t_array_dim *s0 = &dims;
 110   scm_t_array_dim *s1;
 111   unsigned long bas0 = 0;
 112   int i, ndim = 1;
 113   int exact = 2   /* 4 */ ;  /* Don't care about values >2 (yet?) */
 114
 115   if (scm_is_generalized_vector (ra0))
 116     {
 117       s0->lbnd = 0;
 118       s0->inc = 1;
 119       s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
 120     }
 121   else if (SCM_I_ARRAYP (ra0))
 122     {
 123       ndim = SCM_I_ARRAY_NDIM (ra0);
 124       s0 = SCM_I_ARRAY_DIMS (ra0);
 125       bas0 = SCM_I_ARRAY_BASE (ra0);
 126     }
 127   else
 128     return 0;
 129
 130   while (SCM_NIMP (ras))
 131     {
 132       ra1 = SCM_CAR (ras);
 133
 134       if (scm_is_generalized_vector (ra1))
 135         {
 136           size_t length;
 137
 138           if (1 != ndim)
 139             return 0;
 140
 141           length = scm_c_generalized_vector_length (ra1);
 142
 143           switch (exact)
 144             {
 145             case 4:
 146               if (0 != bas0)
 147                 exact = 3;
 148             case 3:
 149               if (1 != s0->inc)
 150                 exact = 2;
 151             case 2:
 152               if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
 153                 break;
 154               exact = 1;
 155             case 1:
 156               if (s0->lbnd < 0 || s0->ubnd >= length)
 157                 return 0;
 158             }
 159         }
 160       else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
 161         {
 162           s1 = SCM_I_ARRAY_DIMS (ra1);
 163           if (bas0 != SCM_I_ARRAY_BASE (ra1))
 164             exact = 3;
 165           for (i = 0; i < ndim; i++)
 166             switch (exact)
 167               {
 168               case 4:
 169               case 3:
 170                 if (s0[i].inc != s1[i].inc)
 171                   exact = 2;
 172               case 2:
 173                 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
 174                   break;
 175                 exact = 1;
 176               default:
 177                 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
 178                   return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
 179               }
 180         }
 181       else
 182         return 0;
 183
 184       ras = SCM_CDR (ras);
 185     }
 186
 187   return exact;
 188 }
 189
 190 /* array mapper: apply cproc to each dimension of the given arrays?.
 191      int (*cproc) ();   procedure to call on unrolled arrays?
 192                            cproc (dest, source list) or
 193                            cproc (dest, data, source list).
 194      SCM data;          data to give to cproc or unbound.
 195      SCM ra0;           destination array.
 196      SCM lra;           list of source arrays.
 197      const char *what;  caller, for error reporting. */
 198 int
 199 scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
 200 {
 201   SCM z;
 202   SCM vra0, ra1, vra1;
 203   SCM lvra, *plvra;
 204   long *vinds;
 205   int k, kmax;
 206   switch (scm_ra_matchp (ra0, lra))
 207     {
 208     default:
 209     case 0:
 210       scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
 211     case 2:
 212     case 3:
 213     case 4:                     /* Try unrolling arrays */
 214       kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
 215       if (kmax < 0)
 216         goto gencase;
 217       vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
 218       if (SCM_IMP (vra0)) goto gencase;
 219       if (!SCM_I_ARRAYP (vra0))
 220         {
 221           size_t length = scm_c_generalized_vector_length (vra0);
 222           vra1 = scm_i_make_ra (1, 0);
 223           SCM_I_ARRAY_BASE (vra1) = 0;
 224           SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
 225           SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
 226           SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 227           SCM_I_ARRAY_V (vra1) = vra0;
 228           vra0 = vra1;
 229         }
 230       lvra = SCM_EOL;
 231       plvra = &lvra;
 232       for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
 233         {
 234           ra1 = SCM_CAR (z);
 235           vra1 = scm_i_make_ra (1, 0);
 236           SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 237           SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 238           if (!SCM_I_ARRAYP (ra1))
 239             {
 240               SCM_I_ARRAY_BASE (vra1) = 0;
 241               SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 242               SCM_I_ARRAY_V (vra1) = ra1;
 243             }
 244           else if (!SCM_I_ARRAY_CONTP (ra1))
 245             goto gencase;
 246           else
 247             {
 248               SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
 249               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 250               SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 251             }
 252           *plvra = scm_cons (vra1, SCM_EOL);
 253           plvra = SCM_CDRLOC (*plvra);
 254         }
 255       return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
 256     case 1:
 257     gencase:                    /* Have to loop over all dimensions. */
 258     vra0 = scm_i_make_ra (1, 0);
 259     if (SCM_I_ARRAYP (ra0))
 260       {
 261         kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
 262         if (kmax < 0)
 263           {
 264             SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 265             SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
 266             SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 267           }
 268         else
 269           {
 270             SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
 271             SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
 272             SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
 273           }
 274         SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
 275         SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
 276       }
 277     else
 278       {
 279         size_t length = scm_c_generalized_vector_length (ra0);
 280         kmax = 0;
 281         SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
 282         SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
 283         SCM_I_ARRAY_DIMS (vra0)->inc = 1;
 284         SCM_I_ARRAY_BASE (vra0) = 0;
 285         SCM_I_ARRAY_V (vra0) = ra0;
 286         ra0 = vra0;
 287       }
 288     lvra = SCM_EOL;
 289     plvra = &lvra;
 290     for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
 291       {
 292         ra1 = SCM_CAR (z);
 293         vra1 = scm_i_make_ra (1, 0);
 294         SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
 295         SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
 296         if (SCM_I_ARRAYP (ra1))
 297           {
 298             if (kmax >= 0)
 299               SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
 300             SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
 301           }
 302         else
 303           {
 304             SCM_I_ARRAY_DIMS (vra1)->inc = 1;
 305             SCM_I_ARRAY_V (vra1) = ra1;
 306           }
 307         *plvra = scm_cons (vra1, SCM_EOL);
 308         plvra = SCM_CDRLOC (*plvra);
 309       }
 310
 311     scm_dynwind_begin (0);
 312
 313     vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
 314     scm_dynwind_free (vinds);
 315
 316     for (k = 0; k <= kmax; k++)
 317       vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
 318     k = kmax;
 319     do
 320       {
 321         if (k == kmax)
 322           {
 323             SCM y = lra;
 324             SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
 325             for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
 326               SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
 327             if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
 328               return 0;
 329             k--;
 330             continue;
 331           }
 332         if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
 333           {
 334             vinds[k]++;
 335             k++;
 336             continue;
 337           }
 338         vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
 339         k--;
 340       }
 341     while (k >= 0);
 342
 343     scm_dynwind_end ();
 344     return 1;
 345     }
 346 }
 347
 348
 349 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 350             (SCM ra, SCM fill),
 351             "Store @var{fill} in every element of @var{array}.  The value returned\n"
 352             "is unspecified.")
 353 #define FUNC_NAME s_scm_array_fill_x
 354 {
 355   scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
 356   return SCM_UNSPECIFIED;
 357 }
 358 #undef FUNC_NAME
 359
 360 /* to be used as cproc in scm_ramapc to fill an array dimension with
 361    "fill". */
 362 int
 363 scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
 364 #define FUNC_NAME s_scm_array_fill_x
 365 {
 366   unsigned long i;
 367   unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
 368   long inc = SCM_I_ARRAY_DIMS (ra)->inc;
 369   unsigned long base = SCM_I_ARRAY_BASE (ra);
 370
 371   ra = SCM_I_ARRAY_V (ra);
 372
 373   for (i = base; n--; i += inc)
 374     GVSET (ra, i, fill);
 375
 376   return 1;
 377 }
 378 #undef FUNC_NAME
 379
 380
 381
 382 static int
 383 racp (SCM src, SCM dst)
 384 {
 385   long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
 386   long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
 387   unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
 388   dst = SCM_CAR (dst);
 389   inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
 390   i_d = SCM_I_ARRAY_BASE (dst);
 391   src = SCM_I_ARRAY_V (src);
 392   dst = SCM_I_ARRAY_V (dst);
 393
 394   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
 395     GVSET (dst, i_d, GVREF (src, i_s));
 396   return 1;
 397 }
 398
 399 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
 400
 401
 402 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 403             (SCM src, SCM dst),
 404             "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
 405             "Copy every element from vector or array @var{source} to the\n"
 406             "corresponding element of @var{destination}.  @var{destination} must have\n"
 407             "the same rank as @var{source}, and be at least as large in each\n"
 408             "dimension.  The order is unspecified.")
 409 #define FUNC_NAME s_scm_array_copy_x
 410 {
 411   scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
 412   return SCM_UNSPECIFIED;
 413 }
 414 #undef FUNC_NAME
 415
 416 /* Functions callable by ARRAY-MAP! */
 417
 418
 419 int
 420 scm_ra_eqp (SCM ra0, SCM ras)
 421 {
 422   SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
 423   scm_t_array_handle ra0_handle;
 424   scm_t_array_dim *ra0_dims;
 425   size_t n;
 426   ssize_t inc0;
 427   size_t i0 = 0;
 428   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 429   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 430   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 431   ra1 = SCM_I_ARRAY_V (ra1);
 432   ra2 = SCM_I_ARRAY_V (ra2);
 433
 434   scm_array_get_handle (ra0, &ra0_handle);
 435   ra0_dims = scm_array_handle_dims (&ra0_handle);
 436   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 437   inc0 = ra0_dims[0].inc;
 438
 439   {
 440     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 441       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 442         if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
 443           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 444   }
 445
 446   scm_array_handle_release (&ra0_handle);
 447   return 1;
 448 }
 449
 450 /* opt 0 means <, nonzero means >= */
 451
 452 static int
 453 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
 454 {
 455   scm_t_array_handle ra0_handle;
 456   scm_t_array_dim *ra0_dims;
 457   size_t n;
 458   ssize_t inc0;
 459   size_t i0 = 0;
 460   unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 461   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 462   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 463   ra1 = SCM_I_ARRAY_V (ra1);
 464   ra2 = SCM_I_ARRAY_V (ra2);
 465
 466   scm_array_get_handle (ra0, &ra0_handle);
 467   ra0_dims = scm_array_handle_dims (&ra0_handle);
 468   n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
 469   inc0 = ra0_dims[0].inc;
 470
 471   {
 472     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 473       if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
 474         if (opt ?
 475             scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
 476             scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
 477           scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
 478   }
 479
 480   scm_array_handle_release (&ra0_handle);
 481   return 1;
 482 }
 483
 484
 485
 486 int
 487 scm_ra_lessp (SCM ra0, SCM ras)
 488 {
 489   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
 490 }
 491
 492
 493 int
 494 scm_ra_leqp (SCM ra0, SCM ras)
 495 {
 496   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
 497 }
 498
 499
 500 int
 501 scm_ra_grp (SCM ra0, SCM ras)
 502 {
 503   return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
 504 }
 505
 506
 507 int
 508 scm_ra_greqp (SCM ra0, SCM ras)
 509 {
 510   return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
 511 }
 512
 513
 514 int
 515 scm_ra_sum (SCM ra0, SCM ras)
 516 {
 517   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 518   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 519   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 520   ra0 = SCM_I_ARRAY_V (ra0);
 521   if (!scm_is_null(ras))
 522     {
 523       SCM ra1 = SCM_CAR (ras);
 524       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 525       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 526       ra1 = SCM_I_ARRAY_V (ra1);
 527       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 528         {
 529         default:
 530           {
 531             for (; n-- > 0; i0 += inc0, i1 += inc1)
 532               GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
 533             break;
 534           }
 535         }
 536     }
 537   return 1;
 538 }
 539
 540
 541
 542 int
 543 scm_ra_difference (SCM ra0, SCM ras)
 544 {
 545   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 546   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 547   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 548   ra0 = SCM_I_ARRAY_V (ra0);
 549   if (scm_is_null (ras))
 550     {
 551       switch (SCM_TYP7 (ra0))
 552         {
 553         default:
 554           {
 555             for (; n-- > 0; i0 += inc0)
 556               GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
 557             break;
 558           }
 559         }
 560     }
 561   else
 562     {
 563       SCM ra1 = SCM_CAR (ras);
 564       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 565       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 566       ra1 = SCM_I_ARRAY_V (ra1);
 567       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 568         {
 569         default:
 570           {
 571             for (; n-- > 0; i0 += inc0, i1 += inc1)
 572               GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
 573                                               GVREF (ra1, i1)));
 574             break;
 575           }
 576         }
 577     }
 578   return 1;
 579 }
 580
 581
 582
 583 int
 584 scm_ra_product (SCM ra0, SCM ras)
 585 {
 586   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 587   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 588   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 589   ra0 = SCM_I_ARRAY_V (ra0);
 590   if (!scm_is_null (ras))
 591     {
 592       SCM ra1 = SCM_CAR (ras);
 593       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 594       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 595       ra1 = SCM_I_ARRAY_V (ra1);
 596       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 597         {
 598         default:
 599           {
 600             for (; n-- > 0; i0 += inc0, i1 += inc1)
 601               GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
 602                                            GVREF (ra1, i1)));
 603           }
 604         }
 605     }
 606   return 1;
 607 }
 608
 609
 610 int
 611 scm_ra_divide (SCM ra0, SCM ras)
 612 {
 613   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 614   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 615   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 616   ra0 = SCM_I_ARRAY_V (ra0);
 617   if (scm_is_null (ras))
 618     {
 619       switch (SCM_TYP7 (ra0))
 620         {
 621         default:
 622           {
 623             for (; n-- > 0; i0 += inc0)
 624               GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
 625             break;
 626           }
 627         }
 628     }
 629   else
 630     {
 631       SCM ra1 = SCM_CAR (ras);
 632       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 633       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 634       ra1 = SCM_I_ARRAY_V (ra1);
 635       switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
 636         {
 637         default:
 638           {
 639             for (; n-- > 0; i0 += inc0, i1 += inc1)
 640               {
 641                 SCM res =  scm_divide (GVREF (ra0, i0),
 642                                        GVREF (ra1, i1));
 643                 GVSET (ra0, i0, res);
 644               }
 645             break;
 646           }
 647         }
 648     }
 649   return 1;
 650 }
 651
 652
 653 int
 654 scm_array_identity (SCM dst, SCM src)
 655 {
 656   return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
 657 }
 658
 659
 660
 661 static int
 662 ramap (SCM ra0, SCM proc, SCM ras)
 663 {
 664   long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 665   long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
 666   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
 667   long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
 668   ra0 = SCM_I_ARRAY_V (ra0);
 669   if (scm_is_null (ras))
 670     for (; i <= n; i++)
 671       GVSET (ra0, i*inc+base, scm_call_0 (proc));
 672   else
 673     {
 674       SCM ra1 = SCM_CAR (ras);
 675       SCM args;
 676       unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
 677       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 678       ra1 = SCM_I_ARRAY_V (ra1);
 679       ras = SCM_CDR (ras);
 680       if (scm_is_null(ras))
 681         ras = scm_nullvect;
 682       else
 683         ras = scm_vector (ras);
 684
 685       for (; i <= n; i++, i1 += inc1)
 686         {
 687           args = SCM_EOL;
 688           for (k = scm_c_vector_length (ras); k--;)
 689             args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
 690           args = scm_cons (GVREF (ra1, i1), args);
 691           GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
 692         }
 693     }
 694   return 1;
 695 }
 696
 697
 698 static int
 699 ramap_dsubr (SCM ra0, SCM proc, SCM ras)
 700 {
 701   SCM ra1 = SCM_CAR (ras);
 702   unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
 703   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 704   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
 705   ra0 = SCM_I_ARRAY_V (ra0);
 706   ra1 = SCM_I_ARRAY_V (ra1);
 707   switch (SCM_TYP7 (ra0))
 708     {
 709     default:
 710       for (; n-- > 0; i0 += inc0, i1 += inc1)
 711         GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
 712       break;
 713     }
 714   return 1;
 715 }
 716
 717
 718
 719 static int
 720 ramap_rp (SCM ra0, SCM proc, SCM ras)
 721 {
 722   SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
 723   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 724   unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
 725   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 726   long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 727   long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
 728   ra0 = SCM_I_ARRAY_V (ra0);
 729   ra1 = SCM_I_ARRAY_V (ra1);
 730   ra2 = SCM_I_ARRAY_V (ra2);
 731
 732   for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 733     if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
 734       if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
 735         scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
 736
 737   return 1;
 738 }
 739
 740
 741
 742 static int
 743 ramap_1 (SCM ra0, SCM proc, SCM ras)
 744 {
 745   SCM ra1 = SCM_CAR (ras);
 746   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 747   unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
 748   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 749   ra0 = SCM_I_ARRAY_V (ra0);
 750   ra1 = SCM_I_ARRAY_V (ra1);
 751   if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
 752     for (; n-- > 0; i0 += inc0, i1 += inc1)
 753       GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
 754   else
 755     for (; n-- > 0; i0 += inc0, i1 += inc1)
 756       GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
 757   return 1;
 758 }
 759
 760
 761
 762 static int
 763 ramap_2o (SCM ra0, SCM proc, SCM ras)
 764 {
 765   SCM ra1 = SCM_CAR (ras);
 766   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 767   unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
 768   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 769   ra0 = SCM_I_ARRAY_V (ra0);
 770   ra1 = SCM_I_ARRAY_V (ra1);
 771   ras = SCM_CDR (ras);
 772   if (scm_is_null (ras))
 773     {
 774       for (; n-- > 0; i0 += inc0, i1 += inc1)
 775         GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
 776     }
 777   else
 778     {
 779       SCM ra2 = SCM_CAR (ras);
 780       unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
 781       long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
 782       ra2 = SCM_I_ARRAY_V (ra2);
 783       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
 784         GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
 785     }
 786   return 1;
 787 }
 788
 789
 790
 791 static int
 792 ramap_a (SCM ra0, SCM proc, SCM ras)
 793 {
 794   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
 795   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 796   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 797   ra0 = SCM_I_ARRAY_V (ra0);
 798   if (scm_is_null (ras))
 799     for (; n-- > 0; i0 += inc0)
 800       GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
 801   else
 802     {
 803       SCM ra1 = SCM_CAR (ras);
 804       unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
 805       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 806       ra1 = SCM_I_ARRAY_V (ra1);
 807       for (; n-- > 0; i0 += inc0, i1 += inc1)
 808         GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
 809     }
 810   return 1;
 811 }
 812
 813
 814 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
 815
 816 SCM_SYMBOL (sym_b, "b");
 817
 818 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 819             (SCM ra0, SCM proc, SCM lra),
 820             "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
 821             "@var{array1}, @dots{} must have the same number of dimensions as\n"
 822             "@var{array0} and have a range for each index which includes the range\n"
 823             "for the corresponding index in @var{array0}.  @var{proc} is applied to\n"
 824             "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
 825             "as the corresponding element in @var{array0}.  The value returned is\n"
 826             "unspecified.  The order of application is unspecified.")
 827 #define FUNC_NAME s_scm_array_map_x
 828 {
 829   SCM_VALIDATE_PROC (2, proc);
 830   SCM_VALIDATE_REST_ARGUMENT (lra);
 831
 832   switch (SCM_TYP7 (proc))
 833     {
 834     default:
 835     gencase:
 836  scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
 837  return SCM_UNSPECIFIED;
 838     case scm_tc7_subr_1:
 839       if (! scm_is_pair (lra))
 840         SCM_WRONG_NUM_ARGS ();  /* need 1 source */
 841       scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
 842       return SCM_UNSPECIFIED;
 843     case scm_tc7_subr_2:
 844       if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
 845         SCM_WRONG_NUM_ARGS ();  /* need 2 sources */
 846       goto subr_2o;
 847     case scm_tc7_subr_2o:
 848       if (! scm_is_pair (lra))
 849         SCM_WRONG_NUM_ARGS ();  /* need 1 source */
 850     subr_2o:
 851       scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
 852       return SCM_UNSPECIFIED;
 853     case scm_tc7_dsubr:
 854       if (! scm_is_pair (lra))
 855         SCM_WRONG_NUM_ARGS ();  /* need 1 source */
 856       scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
 857       return SCM_UNSPECIFIED;
 858     case scm_tc7_rpsubr:
 859       {
 860         ra_iproc *p;
 861         if (!scm_is_typed_array (ra0, sym_b))
 862           goto gencase;
 863         scm_array_fill_x (ra0, SCM_BOOL_T);
 864         for (p = ra_rpsubrs; p->name; p++)
 865           if (scm_is_eq (proc, p->sproc))
 866             {
 867               while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
 868                 {
 869                   scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
 870                   lra = SCM_CDR (lra);
 871                 }
 872               return SCM_UNSPECIFIED;
 873             }
 874         while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
 875           {
 876             scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
 877             lra = SCM_CDR (lra);
 878           }
 879         return SCM_UNSPECIFIED;
 880       }
 881     case scm_tc7_asubr:
 882       if (scm_is_null (lra))
 883         {
 884           SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
 885           scm_array_fill_x (ra0, fill);
 886         }
 887       else
 888         {
 889           SCM tail, ra1 = SCM_CAR (lra);
 890           SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
 891           ra_iproc *p;
 892           /* Check to see if order might matter.
 893              This might be an argument for a separate
 894              SERIAL-ARRAY-MAP! */
 895           if (scm_is_eq (v0, ra1)
 896               || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
 897             if (!scm_is_eq (ra0, ra1)
 898                 || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
 899               goto gencase;
 900           for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
 901             {
 902               ra1 = SCM_CAR (tail);
 903               if (scm_is_eq (v0, ra1)
 904                   || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
 905                 goto gencase;
 906             }
 907           for (p = ra_asubrs; p->name; p++)
 908             if (scm_is_eq (proc, p->sproc))
 909               {
 910                 if (!scm_is_eq (ra0, SCM_CAR (lra)))
 911                   scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
 912                 lra = SCM_CDR (lra);
 913                 while (1)
 914                   {
 915                     scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
 916                     if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
 917                       return SCM_UNSPECIFIED;
 918                     lra = SCM_CDR (lra);
 919                   }
 920               }
 921           scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
 922           lra = SCM_CDR (lra);
 923           if (SCM_NIMP (lra))
 924             for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
 925               scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
 926         }
 927       return SCM_UNSPECIFIED;
 928     }
 929 }
 930 #undef FUNC_NAME
 931
 932
 933 static int
 934 rafe (SCM ra0, SCM proc, SCM ras)
 935 {
 936   long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
 937   unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
 938   long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
 939   long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
 940   ra0 = SCM_I_ARRAY_V (ra0);
 941   if (scm_is_null (ras))
 942     for (; i <= n; i++, i0 += inc0)
 943       scm_call_1 (proc, GVREF (ra0, i0));
 944   else
 945     {
 946       SCM ra1 = SCM_CAR (ras);
 947       SCM args;
 948       unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
 949       long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
 950       ra1 = SCM_I_ARRAY_V (ra1);
 951       ras = SCM_CDR (ras);
 952       if (scm_is_null(ras))
 953         ras = scm_nullvect;
 954       else
 955         ras = scm_vector (ras);
 956       for (; i <= n; i++, i0 += inc0, i1 += inc1)
 957         {
 958           args = SCM_EOL;
 959           for (k = scm_c_vector_length (ras); k--;)
 960             args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
 961           args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
 962           scm_apply_0 (proc, args);
 963         }
 964     }
 965   return 1;
 966 }
 967
 968
 969 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 970             (SCM proc, SCM ra0, SCM lra),
 971             "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
 972             "in row-major order.  The value returned is unspecified.")
 973 #define FUNC_NAME s_scm_array_for_each
 974 {
 975   SCM_VALIDATE_PROC (1, proc);
 976   SCM_VALIDATE_REST_ARGUMENT (lra);
 977   scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
 978   return SCM_UNSPECIFIED;
 979 }
 980 #undef FUNC_NAME
 981
 982 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
 983             (SCM ra, SCM proc),
 984             "Apply @var{proc} to the indices of each element of @var{array} in\n"
 985             "turn, storing the result in the corresponding element.  The value\n"
 986             "returned and the order of application are unspecified.\n\n"
 987             "One can implement @var{array-indexes} as\n"
 988             "@lisp\n"
 989             "(define (array-indexes array)\n"
 990             "    (let ((ra (apply make-array #f (array-shape array))))\n"
 991             "      (array-index-map! ra (lambda x x))\n"
 992             "      ra))\n"
 993             "@end lisp\n"
 994             "Another example:\n"
 995             "@lisp\n"
 996             "(define (apl:index-generator n)\n"
 997             "    (let ((v (make-uniform-vector n 1)))\n"
 998             "      (array-index-map! v (lambda (i) i))\n"
 999             "      v))\n"
1000             "@end lisp")
1001 #define FUNC_NAME s_scm_array_index_map_x
1002 {
1003   unsigned long i;
1004   SCM_VALIDATE_PROC (2, proc);
1005
1006   if (SCM_I_ARRAYP (ra))
1007     {
1008       SCM args = SCM_EOL;
1009       int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
1010       long *vinds;
1011
1012       if (kmax < 0)
1013         return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
1014
1015       scm_dynwind_begin (0);
1016
1017       vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
1018       scm_dynwind_free (vinds);
1019
1020       for (k = 0; k <= kmax; k++)
1021         vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1022       k = kmax;
1023       do
1024         {
1025           if (k == kmax)
1026             {
1027               vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1028               i = cind (ra, vinds);
1029               for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
1030                 {
1031                   for (j = kmax + 1, args = SCM_EOL; j--;)
1032                     args = scm_cons (scm_from_long (vinds[j]), args);
1033                   GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
1034                   i += SCM_I_ARRAY_DIMS (ra)[k].inc;
1035                 }
1036               k--;
1037               continue;
1038             }
1039           if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
1040             {
1041               vinds[k]++;
1042               k++;
1043               continue;
1044             }
1045           vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
1046           k--;
1047         }
1048       while (k >= 0);
1049
1050       scm_dynwind_end ();
1051       return SCM_UNSPECIFIED;
1052     }
1053   else if (scm_is_generalized_vector (ra))
1054     {
1055       size_t length = scm_c_generalized_vector_length (ra);
1056       for (i = 0; i < length; i++)
1057         GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
1058       return SCM_UNSPECIFIED;
1059     }
1060   else
1061     scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1062 }
1063 #undef FUNC_NAME
1064
1065
1066 static int
1067 raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
1068 {
1069   unsigned long i0 = 0, i1 = 0;
1070   long inc0 = 1, inc1 = 1;
1071   unsigned long n;
1072   ra1 = SCM_CAR (ra1);
1073   if (SCM_I_ARRAYP(ra0))
1074     {
1075       n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
1076       i0 = SCM_I_ARRAY_BASE (ra0);
1077       inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
1078       ra0 = SCM_I_ARRAY_V (ra0);
1079     }
1080   else
1081     n = scm_c_generalized_vector_length (ra0);
1082
1083   if (SCM_I_ARRAYP (ra1))
1084     {
1085       i1 = SCM_I_ARRAY_BASE (ra1);
1086       inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
1087       ra1 = SCM_I_ARRAY_V (ra1);
1088     }
1089
1090   if (scm_is_generalized_vector (ra0))
1091     {
1092       for (; n--; i0 += inc0, i1 += inc1)
1093         {
1094           if (scm_is_false (as_equal))
1095             {
1096               if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
1097                 return 0;
1098             }
1099           else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
1100             return 0;
1101         }
1102       return 1;
1103     }
1104   else
1105     return 0;
1106 }
1107
1108
1109
1110 static int
1111 raeql (SCM ra0, SCM as_equal, SCM ra1)
1112 {
1113   SCM v0 = ra0, v1 = ra1;
1114   scm_t_array_dim dim0, dim1;
1115   scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
1116   unsigned long bas0 = 0, bas1 = 0;
1117   int k, unroll = 1, vlen = 1, ndim = 1;
1118   if (SCM_I_ARRAYP (ra0))
1119     {
1120       ndim = SCM_I_ARRAY_NDIM (ra0);
1121       s0 = SCM_I_ARRAY_DIMS (ra0);
1122       bas0 = SCM_I_ARRAY_BASE (ra0);
1123       v0 = SCM_I_ARRAY_V (ra0);
1124     }
1125   else
1126     {
1127       s0->inc = 1;
1128       s0->lbnd = 0;
1129       s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
1130       unroll = 0;
1131     }
1132   if (SCM_I_ARRAYP (ra1))
1133     {
1134       if (ndim != SCM_I_ARRAY_NDIM (ra1))
1135         return 0;
1136       s1 = SCM_I_ARRAY_DIMS (ra1);
1137       bas1 = SCM_I_ARRAY_BASE (ra1);
1138       v1 = SCM_I_ARRAY_V (ra1);
1139     }
1140   else
1141     {
1142       /*
1143         Huh ? Schizophrenic return type. --hwn
1144       */
1145       if (1 != ndim)
1146         return 0;
1147       s1->inc = 1;
1148       s1->lbnd = 0;
1149       s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
1150       unroll = 0;
1151     }
1152   if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
1153     return 0;
1154   for (k = ndim; k--;)
1155     {
1156       if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
1157         return 0;
1158       if (unroll)
1159         {
1160           unroll = (s0[k].inc == s1[k].inc);
1161           vlen *= s0[k].ubnd - s1[k].lbnd + 1;
1162         }
1163     }
1164   if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
1165     return 1;
1166   return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
1167 }
1168
1169
1170 SCM
1171 scm_raequal (SCM ra0, SCM ra1)
1172 {
1173   return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
1174 }
1175
1176 #if 0
1177 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1178 SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
1179              (SCM ra0, SCM ra1),
1180             "Return @code{#t} iff all arguments are arrays with the same\n"
1181             "shape, the same type, and have corresponding elements which are\n"
1182             "either @code{equal?}  or @code{array-equal?}.  This function\n"
1183             "differs from @code{equal?} in that a one dimensional shared\n"
1184             "array may be @var{array-equal?} but not @var{equal?} to a\n"
1185             "vector or uniform vector.")
1186 #define FUNC_NAME s_scm_array_equal_p
1187 {
1188 }
1189 #undef FUNC_NAME
1190 #endif
1191
1192 static char s_array_equal_p[] = "array-equal?";
1193
1194
1195 SCM
1196 scm_array_equal_p (SCM ra0, SCM ra1)
1197 {
1198   if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
1199     return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
1200   return scm_equal_p (ra0, ra1);
1201 }
1202
1203
1204 static void
1205 init_raprocs (ra_iproc *subra)
1206 {
1207   for (; subra->name; subra++)
1208     {
1209       SCM sym = scm_from_locale_symbol (subra->name);
1210       SCM var =
1211         scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
1212       if (var != SCM_BOOL_F)
1213         subra->sproc = SCM_VARIABLE_REF (var);
1214       else
1215         subra->sproc = SCM_BOOL_F;
1216     }
1217 }
1218
1219
1220 void
1221 scm_init_ramap ()
1222 {
1223   init_raprocs (ra_rpsubrs);
1224   init_raprocs (ra_asubrs);
1225   scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
1226   scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
1227 #include "libguile/ramap.x"
1228   scm_add_feature (s_scm_array_for_each);
1229 }
1230
1231 /*
1232   Local Variables:
1233   c-file-style: "gnu"
1234   End:
1235 */