← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/ramap.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/ramap.c
 
1
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006 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
 
 
24
 
 
25
 
 
26
 
 
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
 
 
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
*/