HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
1998-09-30 Mark Galassi <rosalia@cygnus.com>
[bpt/guile.git] / libguile / ramap.c
CommitLineData
0f2d19dd
JB		 1/* Copyright (C) 1996 Free Software Foundation, Inc.
2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program 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
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
0f2d19dd
JB		 41\f
42
43
44\f
45
46#include <stdio.h>
47#include "_scm.h"
20e6290e
JB		 48#include "unif.h"
49#include "smob.h"
50#include "chars.h"
51#include "eq.h"
52#include "eval.h"
53#include "feature.h"
0f2d19dd 54
20e6290e 55#include "ramap.h"
0f2d19dd
JB		 56\f
57
58#ifdef ARRAYS
59
60typedef struct
61{
62 char *name;
63 SCM sproc;
64 int (*vproc) ();
65} ra_iproc;
66
ad310508
MD		 67
68/* These tables are a kluge that will not scale well when more
69 * vectorized subrs are added. It is tempting to steal some bits from
70 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
71 * offset into a table of vectorized subrs.
72 */
73
74static ra_iproc ra_rpsubrs[] =
75{
76 {"=", SCM_UNDEFINED, scm_ra_eqp},
77 {"<", SCM_UNDEFINED, scm_ra_lessp},
78 {"<=", SCM_UNDEFINED, scm_ra_leqp},
79 {">", SCM_UNDEFINED, scm_ra_grp},
80 {">=", SCM_UNDEFINED, scm_ra_greqp},
81 {0, 0, 0}
82};
83
84static ra_iproc ra_asubrs[] =
85{
86 {"+", SCM_UNDEFINED, scm_ra_sum},
87 {"-", SCM_UNDEFINED, scm_ra_difference},
88 {"*", SCM_UNDEFINED, scm_ra_product},
89 {"/", SCM_UNDEFINED, scm_ra_divide},
90 {0, 0, 0}
91};
92
0f2d19dd
JB		 93
94#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
95#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
96#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
97
98/* Fast, recycling scm_vector ref */
99#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
100
101/* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
102
103/* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
104 elements of scm_vector operands are not aliased */
105#ifdef _UNICOS
106#define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
107#else
108#define IVDEP(test, line) line
109#endif
110
111\f
112
113/* inds must be a uvect or ivect, no check. */
114
1cc91f1b
JB		 115
116static scm_sizet cind SCM_P ((SCM ra, SCM inds));
117
0f2d19dd
JB		 118static scm_sizet
119cind (ra, inds)
120 SCM ra;
121 SCM inds;
0f2d19dd
JB		 122{
123 scm_sizet i;
124 int k;
125 long *ve = SCM_VELTS (inds);
126 if (!SCM_ARRAYP (ra))
127 return *ve;
128 i = SCM_ARRAY_BASE (ra);
129 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
130 i += (ve[k] - SCM_ARRAY_DIMS (ra)[k].lbnd) * SCM_ARRAY_DIMS (ra)[k].inc;
131 return i;
132}
133
134
135/* Checker for scm_array mapping functions:
136 return values: 4 --> shapes, increments, and bases are the same;
137 3 --> shapes and increments are the same;
138 2 --> shapes are the same;
139 1 --> ras are at least as big as ra0;
140 0 --> no match.
141 */
1cc91f1b 142
0f2d19dd
JB		 143int
144scm_ra_matchp (ra0, ras)
145 SCM ra0;
146 SCM ras;
0f2d19dd
JB		 147{
148 SCM ra1;
149 scm_array_dim dims;
150 scm_array_dim *s0 = &dims;
151 scm_array_dim *s1;
152 scm_sizet bas0 = 0;
153 int i, ndim = 1;
154 int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
155 if SCM_IMP
156 (ra0) return 0;
157 switch (SCM_TYP7 (ra0))
158 {
159 default:
160 return 0;
161 case scm_tc7_vector:
95f5b0f5 162 case scm_tc7_wvect:
0f2d19dd 163 case scm_tc7_string:
b1d24656 164 case scm_tc7_byvect:
0f2d19dd
JB		 165 case scm_tc7_bvect:
166 case scm_tc7_uvect:
167 case scm_tc7_ivect:
168 case scm_tc7_fvect:
169 case scm_tc7_dvect:
170 case scm_tc7_cvect:
171 s0->lbnd = 0;
172 s0->inc = 1;
173 s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
174 break;
175 case scm_tc7_smob:
176 if (!SCM_ARRAYP (ra0))
177 return 0;
178 ndim = SCM_ARRAY_NDIM (ra0);
179 s0 = SCM_ARRAY_DIMS (ra0);
180 bas0 = SCM_ARRAY_BASE (ra0);
181 break;
182 }
183 while SCM_NIMP
184 (ras)
185 {
186 ra1 = SCM_CAR (ras);
187 if SCM_IMP
188 (ra1) return 0;
189 switch SCM_TYP7
190 (ra1)
191 {
192 default:
193 return 0;
194 case scm_tc7_vector:
95f5b0f5 195 case scm_tc7_wvect:
0f2d19dd 196 case scm_tc7_string:
b1d24656 197 case scm_tc7_byvect:
0f2d19dd
JB		 198 case scm_tc7_bvect:
199 case scm_tc7_uvect:
200 case scm_tc7_ivect:
201 case scm_tc7_fvect:
202 case scm_tc7_dvect:
203 case scm_tc7_cvect:
204 if (1 != ndim)
205 return 0;
206 switch (exact)
207 {
208 case 4:
209 if (0 != bas0)
210 exact = 3;
211 case 3:
212 if (1 != s0->inc)
213 exact = 2;
214 case 2:
215 if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
216 break;
217 exact = 1;
218 case 1:
219 if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
220 return 0;
221 }
222 break;
223 case scm_tc7_smob:
224 if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
225 return 0;
226 s1 = SCM_ARRAY_DIMS (ra1);
227 if (bas0 != SCM_ARRAY_BASE (ra1))
228 exact = 3;
229 for (i = 0; i < ndim; i++)
230 switch (exact)
231 {
232 case 4:
233 case 3:
234 if (s0[i].inc != s1[i].inc)
235 exact = 2;
236 case 2:
237 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
238 break;
239 exact = 1;
240 default:
241 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
242 return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
243 }
244 break;
245 }
246 ras = SCM_CDR (ras);
247 }
248 return exact;
249}
250
251static char s_ra_mismatch[] = "array shape mismatch";
252
0f2d19dd
JB		 253int
254scm_ramapc (cproc, data, ra0, lra, what)
255 int (*cproc) ();
256 SCM data;
257 SCM ra0;
258 SCM lra;
259 char *what;
0f2d19dd
JB		 260{
261 SCM inds, z;
262 SCM vra0, ra1, vra1;
263 SCM lvra, *plvra;
264 long *vinds;
265 int k, kmax;
266 switch (scm_ra_matchp (ra0, lra))
267 {
268 default:
269 case 0:
270 scm_wta (ra0, s_ra_mismatch, what);
271 case 2:
272 case 3:
273 case 4: /* Try unrolling arrays */
274 kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0);
275 if (kmax < 0)
276 goto gencase;
277 vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
278 if SCM_IMP
279 (vra0) goto gencase;
280 if (!SCM_ARRAYP (vra0))
281 {
282 vra1 = scm_make_ra (1);
283 SCM_ARRAY_BASE (vra1) = 0;
284 SCM_ARRAY_DIMS (vra1)->lbnd = 0;
285 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1;
286 SCM_ARRAY_DIMS (vra1)->inc = 1;
287 SCM_ARRAY_V (vra1) = vra0;
288 vra0 = vra1;
289 }
290 lvra = SCM_EOL;
291 plvra = &lvra;
292 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
293 {
294 ra1 = SCM_CAR (z);
295 vra1 = scm_make_ra (1);
296 SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
297 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
298 if (!SCM_ARRAYP (ra1))
299 {
300 SCM_ARRAY_BASE (vra1) = 0;
301 SCM_ARRAY_DIMS (vra1)->inc = 1;
302 SCM_ARRAY_V (vra1) = ra1;
303 }
304 else if (!SCM_ARRAY_CONTP (ra1))
305 goto gencase;
306 else
307 {
308 SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1);
309 SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
310 SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
311 }
312 *plvra = scm_cons (vra1, SCM_EOL);
25d8012c 313 plvra = SCM_CDRLOC (*plvra);
0f2d19dd
JB		 314 }
315 return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
316 case 1:
317 gencase: /* Have to loop over all dimensions. */
318 vra0 = scm_make_ra (1);
319 if SCM_ARRAYP
320 (ra0)
321 {
322 kmax = SCM_ARRAY_NDIM (ra0) - 1;
323 if (kmax < 0)
324 {
325 SCM_ARRAY_DIMS (vra0)->lbnd = 0;
326 SCM_ARRAY_DIMS (vra0)->ubnd = 0;
327 SCM_ARRAY_DIMS (vra0)->inc = 1;
328 }
329 else
330 {
331 SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
332 SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
333 SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
334 }
335 SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
336 SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
337 }
338 else
339 {
340 kmax = 0;
341 SCM_ARRAY_DIMS (vra0)->lbnd = 0;
342 SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
343 SCM_ARRAY_DIMS (vra0)->inc = 1;
344 SCM_ARRAY_BASE (vra0) = 0;
345 SCM_ARRAY_V (vra0) = ra0;
346 ra0 = vra0;
347 }
348 lvra = SCM_EOL;
349 plvra = &lvra;
350 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
351 {
352 ra1 = SCM_CAR (z);
353 vra1 = scm_make_ra (1);
354 SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
355 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
356 if SCM_ARRAYP
357 (ra1)
358 {
359 if (kmax >= 0)
360 SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
361 SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
362 }
363 else
364 {
365 SCM_ARRAY_DIMS (vra1)->inc = 1;
366 SCM_ARRAY_V (vra1) = ra1;
367 }
368 *plvra = scm_cons (vra1, SCM_EOL);
25d8012c 369 plvra = SCM_CDRLOC (*plvra);
0f2d19dd
JB		 370 }
371 inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
372 vinds = (long *) SCM_VELTS (inds);
373 for (k = 0; k <= kmax; k++)
374 vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
375 k = kmax;
376 do
377 {
378 if (k == kmax)
379 {
380 SCM y = lra;
381 SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
382 for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
383 SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
384 if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
385 return 0;
386 k--;
387 continue;
388 }
389 if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
390 {
391 vinds[k]++;
392 k++;
393 continue;
394 }
395 vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
396 k--;
397 }
398 while (k >= 0);
399 return 1;
400 }
401}
402
403
ad310508
MD		 404SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
405
406SCM
407scm_array_fill_x (ra, fill)
408 SCM ra;
409 SCM fill;
410{
411 scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
412 return SCM_UNSPECIFIED;
413}
414
1cc91f1b 415
0f2d19dd
JB		 416int
417scm_array_fill_int (ra, fill, ignore)
418 SCM ra;
419 SCM fill;
420 SCM ignore;
0f2d19dd
JB		 421{
422 scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
423 long inc = SCM_ARRAY_DIMS (ra)->inc;
424 scm_sizet base = SCM_ARRAY_BASE (ra);
425 ra = SCM_ARRAY_V (ra);
426 switch SCM_TYP7
427 (ra)
428 {
429 default:
430 for (i = base; n--; i += inc)
431 scm_array_set_x (ra, fill, SCM_MAKINUM (i));
432 break;
433 case scm_tc7_vector:
95f5b0f5 434 case scm_tc7_wvect:
0f2d19dd
JB		 435 for (i = base; n--; i += inc)
436 SCM_VELTS (ra)[i] = fill;
437 break;
438 case scm_tc7_string:
439 SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
440 for (i = base; n--; i += inc)
441 SCM_CHARS (ra)[i] = SCM_ICHR (fill);
442 break;
b1d24656
MD		 443 case scm_tc7_byvect:
444 if (SCM_ICHRP (fill))
445 fill = SCM_MAKINUM ((char) SCM_ICHR (fill));
446 SCM_ASRTGO (SCM_INUMP (fill)
447 && -128 <= SCM_INUM (fill) && SCM_INUM (fill) < 128,
448 badarg2);
449 for (i = base; n--; i += inc)
450 SCM_CHARS (ra)[i] = SCM_INUM (fill);
451 break;
0f2d19dd
JB		 452 case scm_tc7_bvect:
453 {
454 long *ve = (long *) SCM_VELTS (ra);
455 if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
456 {
457 i = base / SCM_LONG_BIT;
458 if (SCM_BOOL_F == fill)
459 {
460 if (base % SCM_LONG_BIT) /* leading partial word */
461 ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
462 for (; i < (base + n) / SCM_LONG_BIT; i++)
463 ve[i] = 0L;
464 if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
465 ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
466 }
467 else if (SCM_BOOL_T == fill)
468 {
469 if (base % SCM_LONG_BIT)
470 ve[i++] |= ~0L << (base % SCM_LONG_BIT);
471 for (; i < (base + n) / SCM_LONG_BIT; i++)
472 ve[i] = ~0L;
473 if ((base + n) % SCM_LONG_BIT)
474 ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
475 }
476 else
477 badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x);
478 }
479 else
480 {
481 if (SCM_BOOL_F == fill)
482 for (i = base; n--; i += inc)
483 ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
484 else if (SCM_BOOL_T == fill)
485 for (i = base; n--; i += inc)
486 ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
487 else
488 goto badarg2;
489 }
490 break;
491 }
492 case scm_tc7_uvect:
493 SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2);
494 case scm_tc7_ivect:
495 SCM_ASRTGO (SCM_INUMP (fill), badarg2);
496 {
497 long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra);
498 for (i = base; n--; i += inc)
499 ve[i] = f;
500 break;
501 }
502#ifdef SCM_FLOATS
503#ifdef SCM_SINGLES
504 case scm_tc7_fvect:
505 {
506 float f, *ve = (float *) SCM_VELTS (ra);
507 SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
508 f = SCM_REALPART (fill);
509 for (i = base; n--; i += inc)
510 ve[i] = f;
511 break;
512 }
513#endif /* SCM_SINGLES */
514 case scm_tc7_dvect:
515 {
516 double f, *ve = (double *) SCM_VELTS (ra);
517 SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
518 f = SCM_REALPART (fill);
519 for (i = base; n--; i += inc)
520 ve[i] = f;
521 break;
522 }
523 case scm_tc7_cvect:
524 {
525 double fr, fi;
526 double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
527 SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
528 fr = SCM_REALPART (fill);
529 fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
530 for (i = base; n--; i += inc)
531 {
532 ve[i][0] = fr;
533 ve[i][1] = fi;
534 }
535 break;
536 }
537#endif /* SCM_FLOATS */
538 }
539 return 1;
540}
541
0f2d19dd
JB		 542
543
1cc91f1b
JB		 544
545static int racp SCM_P ((SCM dst, SCM src));
546
0f2d19dd
JB		 547static int
548racp (src, dst)
549 SCM dst;
550 SCM src;
0f2d19dd
JB		 551{
552 long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
553 long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
554 scm_sizet i_d, i_s = SCM_ARRAY_BASE (src);
555 dst = SCM_CAR (dst);
556 inc_d = SCM_ARRAY_DIMS (dst)->inc;
557 i_d = SCM_ARRAY_BASE (dst);
558 src = SCM_ARRAY_V (src);
559 dst = SCM_ARRAY_V (dst);
560 switch SCM_TYP7
561 (dst)
562 {
563 default:
95f5b0f5
MD		 564 gencase:
565 case scm_tc7_vector:
566 case scm_tc7_wvect:
567
0f2d19dd
JB		 568 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
569 scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
570 break;
571 case scm_tc7_string:
b1d24656 572 case scm_tc7_byvect:
0f2d19dd
JB		 573 if (scm_tc7_string != SCM_TYP7 (dst))
574 goto gencase;
575 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
576 SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
577 break;
578 case scm_tc7_bvect:
579 if (scm_tc7_bvect != SCM_TYP7 (dst))
580 goto gencase;
581 if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
582 {
583 long *sv = (long *) SCM_VELTS (src);
584 long *dv = (long *) SCM_VELTS (dst);
585 sv += i_s / SCM_LONG_BIT;
586 dv += i_d / SCM_LONG_BIT;
587 if (i_s % SCM_LONG_BIT)
588 { /* leading partial word */
589 *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
590 dv++;
591 sv++;
592 n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
593 }
594 IVDEP (src != dst,
595 for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
596 * dv = *sv;)
597 if (n) /* trailing partial word */
598 *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
599 }
600 else
601 {
602 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
603 if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT)))
604 SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT));
605 else
606 SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT));
607 }
608 break;
609 case scm_tc7_uvect:
610 if (scm_tc7_uvect != SCM_TYP7 (src))
611 goto gencase;
612 else
613 {
614 long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
615 IVDEP (src != dst,
616 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
617 d[i_d] = s[i_s];)
618 break;
619 }
620 case scm_tc7_ivect:
621 if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
622 goto gencase;
623 else
624 {
625 long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
626 IVDEP (src != dst,
627 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
628 d[i_d] = s[i_s];)
629 break;
630 }
631#ifdef SCM_FLOATS
632#ifdef SCM_SINGLES
633 case scm_tc7_fvect:
634 {
635 float *d = (float *) SCM_VELTS (dst);
636 float *s = (float *) SCM_VELTS (src);
637 switch SCM_TYP7
638 (src)
639 {
640 default:
641 goto gencase;
642 case scm_tc7_ivect:
643 case scm_tc7_uvect:
644 IVDEP (src != dst,
645 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
646 d[i_d] = ((long *) s)[i_s];)
647 break;
648 case scm_tc7_fvect:
649 IVDEP (src != dst,
650 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
651 d[i_d] = s[i_s];)
652 break;
653 case scm_tc7_dvect:
654 IVDEP (src != dst,
655 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
656 d[i_d] = ((double *) s)[i_s];)
657 break;
658 }
659 break;
660 }
661#endif /* SCM_SINGLES */
662 case scm_tc7_dvect:
663 {
664 double *d = (double *) SCM_VELTS (dst);
665 double *s = (double *) SCM_VELTS (src);
666 switch SCM_TYP7
667 (src)
668 {
669 default:
670 goto gencase;
671 case scm_tc7_ivect:
672 case scm_tc7_uvect:
673 IVDEP (src != dst,
674 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
675 d[i_d] = ((long *) s)[i_s];)
676 break;
677 case scm_tc7_fvect:
678 IVDEP (src != dst,
679 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
680 d[i_d] = ((float *) s)[i_s];)
681 break;
682 case scm_tc7_dvect:
683 IVDEP (src != dst,
684 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
685 d[i_d] = s[i_s];)
686 break;
687 }
688 break;
689 }
690 case scm_tc7_cvect:
691 {
692 double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
693 double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
694 switch SCM_TYP7
695 (src)
696 {
697 default:
698 goto gencase;
699 case scm_tc7_ivect:
700 case scm_tc7_uvect:
701 IVDEP (src != dst,
702 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
703 {
704 d[i_d][0] = ((long *) s)[i_s];
705 d[i_d][1] = 0.0;
706 }
707 )
708 break;
709 case scm_tc7_fvect:
710 IVDEP (src != dst,
711 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
712 {
713 d[i_d][0] = ((float *) s)[i_s];
714 d[i_d][1] = 0.0;
715 }
716 )
717 break;
718 case scm_tc7_dvect:
719 IVDEP (src != dst,
720 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
721 {
722 d[i_d][0] = ((double *) s)[i_s];
723 d[i_d][1] = 0.0;
724 }
725 )
726 break;
727 case scm_tc7_cvect:
728 IVDEP (src != dst,
729 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
730 {
731 d[i_d][0] = s[i_s][0];
732 d[i_d][1] = s[i_s][1];
733 }
734 )
735 }
736 break;
737 }
738 }
739#endif /* SCM_FLOATS */
740 return 1;
741}
742
743
744SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
745SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
1cc91f1b 746
0f2d19dd
JB		 747SCM
748scm_array_copy_x (src, dst)
749 SCM src;
750 SCM dst;
0f2d19dd
JB		 751{
752 scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
753 return SCM_UNSPECIFIED;
754}
755
756/* Functions callable by ARRAY-MAP! */
757
1cc91f1b 758
0f2d19dd
JB		 759int
760scm_ra_eqp (ra0, ras)
761 SCM ra0;
762 SCM ras;
0f2d19dd
JB		 763{
764 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
765 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
766 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
767 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
768 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
769 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
770 ra0 = SCM_ARRAY_V (ra0);
771 ra1 = SCM_ARRAY_V (ra1);
772 ra2 = SCM_ARRAY_V (ra2);
773 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
774 {
775 default:
776 {
777 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
778 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
779 if BVE_REF
780 (ra0, i0)
781 if SCM_FALSEP
782 (scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
783 BVE_CLR (ra0, i0);
784 break;
785 }
786 case scm_tc7_uvect:
787 case scm_tc7_ivect:
788 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
789 if BVE_REF
790 (ra0, i0)
791 if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
792 BVE_CLR (ra0, i0);
793 break;
794#ifdef SCM_FLOATS
795#ifdef SCM_SINGLES
796 case scm_tc7_fvect:
797 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
798 if BVE_REF
799 (ra0, i0)
800 if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
801 BVE_CLR (ra0, i0);
802 break;
803#endif /*SCM_SINGLES*/
804 case scm_tc7_dvect:
805 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
806 if BVE_REF
807 (ra0, i0)
808 if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
809 BVE_CLR (ra0, i0);
810 break;
811 case scm_tc7_cvect:
812 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
813 if BVE_REF
814 (ra0, i0)
815 if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
816 ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
817 BVE_CLR (ra0, i0);
818 break;
819#endif /*SCM_FLOATS*/
820 }
821 return 1;
822}
823
824/* opt 0 means <, nonzero means >= */
1cc91f1b
JB		 825
826static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt));
827
0f2d19dd
JB		 828static int
829ra_compare (ra0, ra1, ra2, opt)
830 SCM ra0;
831 SCM ra1;
832 SCM ra2;
833 int opt;
0f2d19dd
JB		 834{
835 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
836 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
837 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
838 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
839 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
840 ra0 = SCM_ARRAY_V (ra0);
841 ra1 = SCM_ARRAY_V (ra1);
842 ra2 = SCM_ARRAY_V (ra2);
843 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
844 {
845 default:
846 {
847 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
848 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
849 if BVE_REF
850 (ra0, i0)
851 if (opt ?
852 SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
853 SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
854 BVE_CLR (ra0, i0);
855 break;
856 }
857 case scm_tc7_uvect:
858 case scm_tc7_ivect:
859 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
860 {
861 if BVE_REF
862 (ra0, i0)
863 if (opt ?
864 SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
865 SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
866 BVE_CLR (ra0, i0);
867 }
868 break;
869#ifdef SCM_FLOATS
870#ifdef SCM_SINGLES
871 case scm_tc7_fvect:
872 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
873 if BVE_REF
874 (ra0, i0)
875 if (opt ?
876 ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
877 ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
878 BVE_CLR (ra0, i0);
879 break;
880#endif /*SCM_SINGLES*/
881 case scm_tc7_dvect:
882 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
883 if BVE_REF
884 (ra0, i0)
885 if (opt ?
886 ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
887 ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
888 BVE_CLR (ra0, i0);
889 break;
890#endif /*SCM_FLOATS*/
891 }
892 return 1;
893}
894
895
1cc91f1b 896
0f2d19dd
JB		 897int
898scm_ra_lessp (ra0, ras)
899 SCM ra0;
900 SCM ras;
0f2d19dd
JB		 901{
902 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
903}
904
1cc91f1b 905
0f2d19dd
JB		 906int
907scm_ra_leqp (ra0, ras)
908 SCM ra0;
909 SCM ras;
0f2d19dd
JB		 910{
911 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
912}
913
1cc91f1b 914
0f2d19dd
JB		 915int
916scm_ra_grp (ra0, ras)
917 SCM ra0;
918 SCM ras;
0f2d19dd
JB		 919{
920 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
921}
922
1cc91f1b 923
0f2d19dd
JB		 924int
925scm_ra_greqp (ra0, ras)
926 SCM ra0;
927 SCM ras;
0f2d19dd
JB		 928{
929 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
930}
931
932
1cc91f1b 933
0f2d19dd
JB		 934int
935scm_ra_sum (ra0, ras)
936 SCM ra0;
937 SCM ras;
0f2d19dd
JB		 938{
939 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
940 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
941 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
942 ra0 = SCM_ARRAY_V (ra0);
943 if SCM_NNULLP
944 (ras)
945 {
946 SCM ra1 = SCM_CAR (ras);
947 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
948 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
949 ra1 = SCM_ARRAY_V (ra1);
950 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
951 {
952 default:
953 {
954 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
955 for (; n-- > 0; i0 += inc0, i1 += inc1)
956 scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
957 SCM_MAKINUM (i0));
958 break;
959 }
960 case scm_tc7_uvect:
961 case scm_tc7_ivect:
962 {
963 long *v0 = SCM_VELTS (ra0);
964 long *v1 = SCM_VELTS (ra1);
965 IVDEP (ra0 != ra1,
966 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 967 v0[i0] += v1[i1];)
0f2d19dd
JB		 968 break;
969 }
970#ifdef SCM_FLOATS
971#ifdef SCM_SINGLES
972 case scm_tc7_fvect:
973 {
974 float *v0 = (float *) SCM_VELTS (ra0);
975 float *v1 = (float *) SCM_VELTS (ra1);
976 IVDEP (ra0 != ra1,
977 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 978 v0[i0] += v1[i1];)
0f2d19dd
JB		 979 break;
980 }
981#endif /* SCM_SINGLES */
982 case scm_tc7_dvect:
983 {
984 double *v0 = (double *) SCM_VELTS (ra0);
985 double *v1 = (double *) SCM_VELTS (ra1);
986 IVDEP (ra0 != ra1,
987 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 988 v0[i0] += v1[i1];)
0f2d19dd
JB		 989 break;
990 }
991 case scm_tc7_cvect:
992 {
993 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
994 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
995 IVDEP (ra0 != ra1,
996 for (; n-- > 0; i0 += inc0, i1 += inc1)
997 {
998 v0[i0][0] += v1[i1][0];
999 v0[i0][1] += v1[i1][1];
1000 }
1001 );
1002 break;
1003 }
1004#endif /* SCM_FLOATS */
1005 }
1006 }
1007 return 1;
1008}
1009
1010
1cc91f1b 1011
0f2d19dd
JB		 1012int
1013scm_ra_difference (ra0, ras)
1014 SCM ra0;
1015 SCM ras;
0f2d19dd
JB		 1016{
1017 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1018 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1019 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1020 ra0 = SCM_ARRAY_V (ra0);
1021 if SCM_NULLP
1022 (ras)
1023 {
1024 switch SCM_TYP7
1025 (ra0)
1026 {
1027 default:
1028 {
1029 SCM e0 = SCM_UNDEFINED;
1030 for (; n-- > 0; i0 += inc0)
1031 scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1032 break;
1033 }
1034#ifdef SCM_FLOATS
1035#ifdef SCM_SINGLES
1036 case scm_tc7_fvect:
1037 {
1038 float *v0 = (float *) SCM_VELTS (ra0);
1039 for (; n-- > 0; i0 += inc0)
1040 v0[i0] = -v0[i0];
1041 break;
1042 }
1043#endif /* SCM_SINGLES */
1044 case scm_tc7_dvect:
1045 {
1046 double *v0 = (double *) SCM_VELTS (ra0);
1047 for (; n-- > 0; i0 += inc0)
1048 v0[i0] = -v0[i0];
1049 break;
1050 }
1051 case scm_tc7_cvect:
1052 {
1053 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1054 for (; n-- > 0; i0 += inc0)
1055 {
1056 v0[i0][0] = -v0[i0][0];
1057 v0[i0][1] = -v0[i0][1];
1058 }
1059 break;
1060 }
1061#endif /* SCM_FLOATS */
1062 }
1063 }
1064 else
1065 {
1066 SCM ra1 = SCM_CAR (ras);
1067 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1068 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1069 ra1 = SCM_ARRAY_V (ra1);
1070 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1071 {
1072 default:
1073 {
1074 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1075 for (; n-- > 0; i0 += inc0, i1 += inc1)
1076 scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1077 break;
1078 }
1079#ifdef SCM_FLOATS
1080#ifdef SCM_SINGLES
1081 case scm_tc7_fvect:
1082 {
1083 float *v0 = (float *) SCM_VELTS (ra0);
1084 float *v1 = (float *) SCM_VELTS (ra1);
1085 IVDEP (ra0 != ra1,
1086 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1087 v0[i0] -= v1[i1];)
0f2d19dd
JB		 1088 break;
1089 }
1090#endif /* SCM_SINGLES */
1091 case scm_tc7_dvect:
1092 {
1093 double *v0 = (double *) SCM_VELTS (ra0);
1094 double *v1 = (double *) SCM_VELTS (ra1);
1095 IVDEP (ra0 != ra1,
1096 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1097 v0[i0] -= v1[i1];)
0f2d19dd
JB		 1098 break;
1099 }
1100 case scm_tc7_cvect:
1101 {
1102 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1103 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1104 IVDEP (ra0 != ra1,
1105 for (; n-- > 0; i0 += inc0, i1 += inc1)
1106 {
1107 v0[i0][0] -= v1[i1][0];
1108 v0[i0][1] -= v1[i1][1];
1109 }
1110 )
1111 break;
1112 }
1113#endif /* SCM_FLOATS */
1114 }
1115 }
1116 return 1;
1117}
1118
1119
1cc91f1b 1120
0f2d19dd
JB		 1121int
1122scm_ra_product (ra0, ras)
1123 SCM ra0;
1124 SCM ras;
0f2d19dd
JB		 1125{
1126 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1127 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1128 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1129 ra0 = SCM_ARRAY_V (ra0);
1130 if SCM_NNULLP
1131 (ras)
1132 {
1133 SCM ra1 = SCM_CAR (ras);
1134 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1135 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1136 ra1 = SCM_ARRAY_V (ra1);
1137 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1138 {
1139 default:
1140 {
1141 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1142 for (; n-- > 0; i0 += inc0, i1 += inc1)
1143 scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1144 SCM_MAKINUM (i0));
1145 break;
1146 }
1147 case scm_tc7_uvect:
1148 case scm_tc7_ivect:
1149 {
1150 long *v0 = SCM_VELTS (ra0);
1151 long *v1 = SCM_VELTS (ra1);
1152 IVDEP (ra0 != ra1,
1153 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1154 v0[i0] *= v1[i1];)
0f2d19dd
JB		 1155 break;
1156 }
1157#ifdef SCM_FLOATS
1158#ifdef SCM_SINGLES
1159 case scm_tc7_fvect:
1160 {
1161 float *v0 = (float *) SCM_VELTS (ra0);
1162 float *v1 = (float *) SCM_VELTS (ra1);
1163 IVDEP (ra0 != ra1,
1164 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1165 v0[i0] *= v1[i1];)
0f2d19dd
JB		 1166 break;
1167 }
1168#endif /* SCM_SINGLES */
1169 case scm_tc7_dvect:
1170 {
1171 double *v0 = (double *) SCM_VELTS (ra0);
1172 double *v1 = (double *) SCM_VELTS (ra1);
1173 IVDEP (ra0 != ra1,
1174 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1175 v0[i0] *= v1[i1];)
0f2d19dd
JB		 1176 break;
1177 }
1178 case scm_tc7_cvect:
1179 {
1180 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1181 register double r;
1182 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1183 IVDEP (ra0 != ra1,
1184 for (; n-- > 0; i0 += inc0, i1 += inc1)
1185 {
1186 r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
1187 v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
1188 v0[i0][0] = r;
1189 }
1190 );
1191 break;
1192 }
1193#endif /* SCM_FLOATS */
1194 }
1195 }
1196 return 1;
1197}
1198
1cc91f1b 1199
0f2d19dd
JB		 1200int
1201scm_ra_divide (ra0, ras)
1202 SCM ra0;
1203 SCM ras;
0f2d19dd
JB		 1204{
1205 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1206 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1207 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1208 ra0 = SCM_ARRAY_V (ra0);
1209 if SCM_NULLP
1210 (ras)
1211 {
1212 switch SCM_TYP7
1213 (ra0)
1214 {
1215 default:
1216 {
1217 SCM e0 = SCM_UNDEFINED;
1218 for (; n-- > 0; i0 += inc0)
1219 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1220 break;
1221 }
1222#ifdef SCM_FLOATS
1223#ifdef SCM_SINGLES
1224 case scm_tc7_fvect:
1225 {
1226 float *v0 = (float *) SCM_VELTS (ra0);
1227 for (; n-- > 0; i0 += inc0)
1228 v0[i0] = 1.0 / v0[i0];
1229 break;
1230 }
1231#endif /* SCM_SINGLES */
1232 case scm_tc7_dvect:
1233 {
1234 double *v0 = (double *) SCM_VELTS (ra0);
1235 for (; n-- > 0; i0 += inc0)
1236 v0[i0] = 1.0 / v0[i0];
1237 break;
1238 }
1239 case scm_tc7_cvect:
1240 {
1241 register double d;
1242 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1243 for (; n-- > 0; i0 += inc0)
1244 {
1245 d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
1246 v0[i0][0] /= d;
1247 v0[i0][1] /= -d;
1248 }
1249 break;
1250 }
1251#endif /* SCM_FLOATS */
1252 }
1253 }
1254 else
1255 {
1256 SCM ra1 = SCM_CAR (ras);
1257 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1258 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1259 ra1 = SCM_ARRAY_V (ra1);
1260 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1261 {
1262 default:
1263 {
1264 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1265 for (; n-- > 0; i0 += inc0, i1 += inc1)
1266 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1267 break;
1268 }
1269#ifdef SCM_FLOATS
1270#ifdef SCM_SINGLES
1271 case scm_tc7_fvect:
1272 {
1273 float *v0 = (float *) SCM_VELTS (ra0);
1274 float *v1 = (float *) SCM_VELTS (ra1);
1275 IVDEP (ra0 != ra1,
1276 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1277 v0[i0] /= v1[i1];)
0f2d19dd
JB		 1278 break;
1279 }
1280#endif /* SCM_SINGLES */
1281 case scm_tc7_dvect:
1282 {
1283 double *v0 = (double *) SCM_VELTS (ra0);
1284 double *v1 = (double *) SCM_VELTS (ra1);
1285 IVDEP (ra0 != ra1,
1286 for (; n-- > 0; i0 += inc0, i1 += inc1)
01e2a66d 1287 v0[i0] /= v1[i1];)
0f2d19dd
JB		 1288 break;
1289 }
1290 case scm_tc7_cvect:
1291 {
1292 register double d, r;
1293 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1294 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1295 IVDEP (ra0 != ra1,
1296 for (; n-- > 0; i0 += inc0, i1 += inc1)
1297 {
1298 d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
1299 r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
1300 v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
1301 v0[i0][0] = r;
1302 }
1303 )
1304 break;
1305 }
1306#endif /* SCM_FLOATS */
1307 }
1308 }
1309 return 1;
1310}
1311
1cc91f1b 1312
0f2d19dd
JB		 1313int
1314scm_array_identity (dst, src)
1315 SCM src;
1316 SCM dst;
0f2d19dd
JB		 1317{
1318 return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
1319}
1320
1321
1cc91f1b
JB		 1322
1323static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras));
1324
0f2d19dd
JB		 1325static int
1326ramap (ra0, proc, ras)
1327 SCM ra0;
1328 SCM proc;
1329 SCM ras;
0f2d19dd
JB		 1330{
1331 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1332 long inc = SCM_ARRAY_DIMS (ra0)->inc;
1333 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1334 long base = SCM_ARRAY_BASE (ra0) - i * inc;
1335 ra0 = SCM_ARRAY_V (ra0);
1336 if SCM_NULLP
1337 (ras)
1338 for (; i <= n; i++)
1339 scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
1340 else
1341 {
1342 SCM ra1 = SCM_CAR (ras);
1343 SCM args, *ve = &ras;
1344 scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
1345 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1346 ra1 = SCM_ARRAY_V (ra1);
1347 ras = SCM_CDR (ras);
1348 if SCM_NULLP
1349 (ras)
1350 ras = scm_nullvect;
1351 else
1352 {
1353 ras = scm_vector (ras);
1354 ve = SCM_VELTS (ras);
1355 }
1356 for (; i <= n; i++, i1 += inc1)
1357 {
1358 args = SCM_EOL;
1359 for (k = SCM_LENGTH (ras); k--;)
1360 args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
1361 args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1362 scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base));
1363 }
1364 }
1365 return 1;
1366}
1367
1cc91f1b
JB		 1368
1369static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras));
1370
0f2d19dd
JB		 1371static int
1372ramap_cxr (ra0, proc, ras)
1373 SCM ra0;
1374 SCM proc;
1375 SCM ras;
0f2d19dd
JB		 1376{
1377 SCM ra1 = SCM_CAR (ras);
1378 SCM e1 = SCM_UNDEFINED;
1379 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1380 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1381 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1;
1382 ra0 = SCM_ARRAY_V (ra0);
1383 ra1 = SCM_ARRAY_V (ra1);
1384 switch SCM_TYP7
1385 (ra0)
1386 {
1387 default:
1388 gencase:
1389 for (; n-- > 0; i0 += inc0, i1 += inc1)
1390 scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
1391 break;
1392#ifdef SCM_FLOATS
1393#ifdef SCM_SINGLES
1394 case scm_tc7_fvect:
1395 {
1396 float *dst = (float *) SCM_VELTS (ra0);
1397 switch SCM_TYP7
1398 (ra1)
1399 {
1400 default:
1401 goto gencase;
1402 case scm_tc7_fvect:
1403 for (; n-- > 0; i0 += inc0, i1 += inc1)
1404 dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
1405 break;
1406 case scm_tc7_uvect:
1407 case scm_tc7_ivect:
1408 for (; n-- > 0; i0 += inc0, i1 += inc1)
1409 dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
1410 break;
1411 }
1412 break;
1413 }
1414#endif /* SCM_SINGLES */
1415 case scm_tc7_dvect:
1416 {
1417 double *dst = (double *) SCM_VELTS (ra0);
1418 switch SCM_TYP7
1419 (ra1)
1420 {
1421 default:
1422 goto gencase;
1423 case scm_tc7_dvect:
1424 for (; n-- > 0; i0 += inc0, i1 += inc1)
1425 dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
1426 break;
1427 case scm_tc7_uvect:
1428 case scm_tc7_ivect:
1429 for (; n-- > 0; i0 += inc0, i1 += inc1)
1430 dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
1431 break;
1432 }
1433 break;
1434 }
1435#endif /* SCM_FLOATS */
1436 }
1437 return 1;
1438}
1439
1440
1cc91f1b
JB		 1441
1442static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras));
1443
0f2d19dd
JB		 1444static int
1445ramap_rp (ra0, proc, ras)
1446 SCM ra0;
1447 SCM proc;
1448 SCM ras;
0f2d19dd
JB		 1449{
1450 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
1451 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
1452 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1453 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
1454 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1455 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1456 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
1457 ra0 = SCM_ARRAY_V (ra0);
1458 ra1 = SCM_ARRAY_V (ra1);
1459 ra2 = SCM_ARRAY_V (ra2);
1460 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
1461 {
1462 default:
1463 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1464 if BVE_REF
1465 (ra0, i0)
1466 if SCM_FALSEP
1467 (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
1468 BVE_CLR (ra0, i0);
1469 break;
1470 case scm_tc7_uvect:
1471 case scm_tc7_ivect:
1472 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1473 if BVE_REF
1474 (ra0, i0)
1475 {
1476 if SCM_FALSEP
1477 (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
1478 SCM_MAKINUM (SCM_VELTS (ra2)[i2])))
1479 BVE_CLR (ra0, i0);
1480 }
1481 break;
1482#ifdef SCM_FLOATS
1483#ifdef SCM_SINGLES
1484 case scm_tc7_fvect:
1485 {
1486 SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
1487 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1488 if BVE_REF
1489 (ra0, i0)
1490 {
1491 SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
1492 SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
1493 if SCM_FALSEP
1494 (SCM_SUBRF (proc) (a1, a2))
1495 BVE_CLR (ra0, i0);
1496 }
1497 break;
1498 }
1499#endif /*SCM_SINGLES*/
1500 case scm_tc7_dvect:
1501 {
1502 SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
1503 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1504 if BVE_REF
1505 (ra0, i0)
1506 {
1507 SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
1508 SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
1509 if SCM_FALSEP
1510 (SCM_SUBRF (proc) (a1, a2))
1511 BVE_CLR (ra0, i0);
1512 }
1513 break;
1514 }
1515 case scm_tc7_cvect:
1516 {
1517 SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
1518 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1519 if BVE_REF
1520 (ra0, i0)
1521 {
1522 SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
1523 SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
1524 SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
1525 SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
1526 if SCM_FALSEP
1527 (SCM_SUBRF (proc) (a1, a2))
1528 BVE_CLR (ra0, i0);
1529 }
1530 break;
1531 }
1532#endif /*SCM_FLOATS*/
1533 }
1534 return 1;
1535}
1536
1537
1cc91f1b
JB		 1538
1539static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras));
1540
0f2d19dd
JB		 1541static int
1542ramap_1 (ra0, proc, ras)
1543 SCM ra0;
1544 SCM proc;
1545 SCM ras;
0f2d19dd
JB		 1546{
1547 SCM ra1 = SCM_CAR (ras);
1548 SCM e1 = SCM_UNDEFINED;
1549 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1550 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1551 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1552 ra0 = SCM_ARRAY_V (ra0);
1553 ra1 = SCM_ARRAY_V (ra1);
95f5b0f5 1554 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
0f2d19dd
JB		 1555 for (; n-- > 0; i0 += inc0, i1 += inc1)
1556 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0));
1557 else
1558 for (; n-- > 0; i0 += inc0, i1 += inc1)
1559 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1560 return 1;
1561}
1562
1563
1cc91f1b
JB		 1564
1565static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras));
1566
0f2d19dd
JB		 1567static int
1568ramap_2o (ra0, proc, ras)
1569 SCM ra0;
1570 SCM proc;
1571 SCM ras;
0f2d19dd
JB		 1572{
1573 SCM ra1 = SCM_CAR (ras);
1574 SCM e1 = SCM_UNDEFINED;
1575 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1576 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1577 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1578 ra0 = SCM_ARRAY_V (ra0);
1579 ra1 = SCM_ARRAY_V (ra1);
1580 ras = SCM_CDR (ras);
1581 if SCM_NULLP
1582 (ras)
1583 {
95f5b0f5
MD		 1584 if (scm_tc7_vector == SCM_TYP7 (ra0)
1585 || scm_tc7_wvect == SCM_TYP7 (ra0))
1586
0f2d19dd
JB		 1587 for (; n-- > 0; i0 += inc0, i1 += inc1)
1588 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
1589 SCM_MAKINUM (i0));
1590 else
1591 for (; n-- > 0; i0 += inc0, i1 += inc1)
1592 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
1593 SCM_MAKINUM (i0));
1594 }
1595 else
1596 {
1597 SCM ra2 = SCM_CAR (ras);
1598 SCM e2 = SCM_UNDEFINED;
1599 scm_sizet i2 = SCM_ARRAY_BASE (ra2);
1600 long inc2 = SCM_ARRAY_DIMS (ra2)->inc;
1601 ra2 = SCM_ARRAY_V (ra2);
95f5b0f5 1602 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
0f2d19dd
JB		 1603 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1604 scm_array_set_x (ra0,
1605 SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
1606 SCM_MAKINUM (i0));
1607 else
1608 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1609 scm_array_set_x (ra0,
1610 SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
1611 SCM_MAKINUM (i0));
1612 }
1613 return 1;
1614}
1615
1616
1cc91f1b
JB		 1617
1618static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras));
1619
0f2d19dd
JB		 1620static int
1621ramap_a (ra0, proc, ras)
1622 SCM ra0;
1623 SCM proc;
1624 SCM ras;
0f2d19dd
JB		 1625{
1626 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1627 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1628 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1629 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1630 ra0 = SCM_ARRAY_V (ra0);
1631 if SCM_NULLP
1632 (ras)
1633 for (; n-- > 0; i0 += inc0)
1634 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1635 else
1636 {
1637 SCM ra1 = SCM_CAR (ras);
1638 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1639 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1640 ra1 = SCM_ARRAY_V (ra1);
1641 for (; n-- > 0; i0 += inc0, i1 += inc1)
1642 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1643 SCM_MAKINUM (i0));
1644 }
1645 return 1;
1646}
1647
7e790400
MD		 1648SCM_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
1649SCM_PROC(s_array_map_x, "array-map!", 2, 0, 1, scm_array_map_x);
1cc91f1b 1650
0f2d19dd 1651SCM
7e790400 1652scm_array_map_x (ra0, proc, lra)
0f2d19dd
JB		 1653 SCM ra0;
1654 SCM proc;
1655 SCM lra;
0f2d19dd 1656{
7e790400 1657 SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map_x);
0f2d19dd
JB		 1658 switch (SCM_TYP7 (proc))
1659 {
1660 default:
1661 gencase:
7e790400 1662 scm_ramapc (ramap, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1663 return SCM_UNSPECIFIED;
1664 case scm_tc7_subr_1:
7e790400 1665 scm_ramapc (ramap_1, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1666 return SCM_UNSPECIFIED;
1667 case scm_tc7_subr_2:
1668 case scm_tc7_subr_2o:
7e790400 1669 scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1670 return SCM_UNSPECIFIED;
1671 case scm_tc7_cxr:
1672 if (!SCM_SUBRF (proc))
1673 goto gencase;
7e790400 1674 scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1675 return SCM_UNSPECIFIED;
1676 case scm_tc7_rpsubr:
1677 {
1678 ra_iproc *p;
1679 if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
1680 goto gencase;
1681 scm_array_fill_x (ra0, SCM_BOOL_T);
1682 for (p = ra_rpsubrs; p->name; p++)
1683 if (proc == p->sproc)
1684 {
1685 while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
1686 {
7e790400 1687 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1688 lra = SCM_CDR (lra);
1689 }
1690 return SCM_UNSPECIFIED;
1691 }
1692 while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
1693 {
7e790400 1694 scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1695 lra = SCM_CDR (lra);
1696 }
1697 return SCM_UNSPECIFIED;
1698 }
1699 case scm_tc7_asubr:
1700 if SCM_NULLP
1701 (lra)
1702 {
1703 SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
1704 if SCM_INUMP
1705 (fill)
1706 {
1707 prot = scm_array_prototype (ra0);
1708 if (SCM_NIMP (prot) && SCM_INEXP (prot))
1709 fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
1710 }
1711
1712 scm_array_fill_x (ra0, fill);
1713 }
1714 else
1715 {
1716 SCM tail, ra1 = SCM_CAR (lra);
1717 SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
1718 ra_iproc *p;
1719 /* Check to see if order might matter.
1720 This might be an argument for a separate
1721 SERIAL-ARRAY-MAP! */
1722 if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
1723 if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
1724 goto gencase;
1725 for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
1726 {
1727 ra1 = SCM_CAR (tail);
1728 if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
1729 goto gencase;
1730 }
1731 for (p = ra_asubrs; p->name; p++)
1732 if (proc == p->sproc)
1733 {
1734 if (ra0 != SCM_CAR (lra))
7e790400 1735 scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map_x);
0f2d19dd
JB		 1736 lra = SCM_CDR (lra);
1737 while (1)
1738 {
7e790400 1739 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1740 if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
1741 return SCM_UNSPECIFIED;
1742 lra = SCM_CDR (lra);
1743 }
1744 }
7e790400 1745 scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1746 lra = SCM_CDR (lra);
1747 if SCM_NIMP
1748 (lra)
1749 for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
7e790400 1750 scm_ramapc (ramap_a, proc, ra0, lra, s_array_map_x);
0f2d19dd
JB		 1751 }
1752 return SCM_UNSPECIFIED;
1753 }
1754}
1755
1cc91f1b
JB		 1756
1757static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras));
1758
0f2d19dd
JB		 1759static int
1760rafe (ra0, proc, ras)
1761 SCM ra0;
1762 SCM proc;
1763 SCM ras;
0f2d19dd
JB		 1764{
1765 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1766 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1767 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1768 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1769 ra0 = SCM_ARRAY_V (ra0);
1770 if SCM_NULLP
1771 (ras)
1772 for (; i <= n; i++, i0 += inc0)
1773 scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
1774 else
1775 {
1776 SCM ra1 = SCM_CAR (ras);
1777 SCM args, *ve = &ras;
1778 scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
1779 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1780 ra1 = SCM_ARRAY_V (ra1);
1781 ras = SCM_CDR (ras);
1782 if SCM_NULLP
1783 (ras)
1784 ras = scm_nullvect;
1785 else
1786 {
1787 ras = scm_vector (ras);
1788 ve = SCM_VELTS (ras);
1789 }
1790 for (; i <= n; i++, i0 += inc0, i1 += inc1)
1791 {
1792 args = SCM_EOL;
1793 for (k = SCM_LENGTH (ras); k--;)
1794 args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
1795 args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1796 scm_apply (proc, args, SCM_EOL);
1797 }
1798 }
1799 return 1;
1800}
1801
1802
1803SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
1cc91f1b 1804
0f2d19dd
JB		 1805SCM
1806scm_array_for_each (proc, ra0, lra)
1807 SCM proc;
1808 SCM ra0;
1809 SCM lra;
0f2d19dd
JB		 1810{
1811 SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each);
1812 scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
1813 return SCM_UNSPECIFIED;
1814}
1815
1816SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x);
1cc91f1b 1817
0f2d19dd
JB		 1818SCM
1819scm_array_index_map_x (ra, proc)
1820 SCM ra;
1821 SCM proc;
0f2d19dd
JB		 1822{
1823 scm_sizet i;
1824 SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x);
e42c09cc
RS		 1825 SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2,
1826 s_array_index_map_x);
1827 switch (SCM_TYP7(ra))
1828 {
1829 default:
1830 badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x);
1831 case scm_tc7_vector:
1832 case scm_tc7_wvect:
0f2d19dd 1833 {
e42c09cc 1834 SCM *ve = SCM_VELTS (ra);
0f2d19dd 1835 for (i = 0; i < SCM_LENGTH (ra); i++)
e42c09cc
RS		 1836 ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
1837 return SCM_UNSPECIFIED;
1838 }
1839 case scm_tc7_string:
1840 case scm_tc7_byvect:
1841 case scm_tc7_bvect:
1842 case scm_tc7_uvect:
1843 case scm_tc7_ivect:
1844 case scm_tc7_fvect:
1845 case scm_tc7_dvect:
1846 case scm_tc7_cvect:
1847 for (i = 0; i < SCM_LENGTH (ra); i++)
1848 scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull),
1849 SCM_MAKINUM (i));
1850 return SCM_UNSPECIFIED;
1851 case scm_tc7_smob:
1852 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
1853 {
1854 SCM args = SCM_EOL;
1855 SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L));
1856 long *vinds = SCM_VELTS (inds);
1857 int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
1858 if (kmax < 0)
1859 return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL),
1860 SCM_EOL);
1861 for (k = 0; k <= kmax; k++)
1862 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1863 k = kmax;
1864 do
1865 {
1866 if (k == kmax)
1867 {
1868 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1869 i = cind (ra, inds);
1870 for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
1871 {
1872 for (j = kmax + 1, args = SCM_EOL; j--;)
1873 args = scm_cons (SCM_MAKINUM (vinds[j]), args);
1874 scm_array_set_x (SCM_ARRAY_V (ra),
1875 scm_apply (proc, args, SCM_EOL),
1876 SCM_MAKINUM (i));
1877 i += SCM_ARRAY_DIMS (ra)[k].inc;
1878 }
1879 k--;
1880 continue;
1881 }
1882 if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd)
1883 {
1884 vinds[k]++;
1885 k++;
1886 continue;
1887 }
1888 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1;
1889 k--;
1890 }
1891 while (k >= 0);
0f2d19dd 1892 return SCM_UNSPECIFIED;
0f2d19dd 1893 }
e42c09cc 1894 }
0f2d19dd
JB		 1895}
1896
1cc91f1b
JB		 1897
1898static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
1899
0f2d19dd
JB		 1900static int
1901raeql_1 (ra0, as_equal, ra1)
1902 SCM ra0;
1903 SCM as_equal;
1904 SCM ra1;
0f2d19dd
JB		 1905{
1906 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1907 scm_sizet i0 = 0, i1 = 0;
1908 long inc0 = 1, inc1 = 1;
1909 scm_sizet n = SCM_LENGTH (ra0);
1910 ra1 = SCM_CAR (ra1);
1911 if SCM_ARRAYP
1912 (ra0)
1913 {
1914 n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1915 i0 = SCM_ARRAY_BASE (ra0);
1916 inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1917 ra0 = SCM_ARRAY_V (ra0);
1918 }
1919 if SCM_ARRAYP
1920 (ra1)
1921 {
1922 i1 = SCM_ARRAY_BASE (ra1);
1923 inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1924 ra1 = SCM_ARRAY_V (ra1);
1925 }
1926 switch SCM_TYP7
1927 (ra0)
1928 {
1929 case scm_tc7_vector:
95f5b0f5 1930 case scm_tc7_wvect:
0f2d19dd
JB		 1931 default:
1932 for (; n--; i0 += inc0, i1 += inc1)
1933 {
1934 if SCM_FALSEP
1935 (as_equal)
1936 {
1937 if SCM_FALSEP
1938 (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
1939 return 0;
1940 }
1941 else if SCM_FALSEP
1942 (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
1943 return 0;
1944 }
1945 return 1;
1946 case scm_tc7_string:
b1d24656 1947 case scm_tc7_byvect:
0f2d19dd
JB		 1948 {
1949 char *v0 = SCM_CHARS (ra0) + i0;
1950 char *v1 = SCM_CHARS (ra1) + i1;
1951 for (; n--; v0 += inc0, v1 += inc1)
1952 if (*v0 != *v1)
1953 return 0;
1954 return 1;
1955 }
1956 case scm_tc7_bvect:
1957 for (; n--; i0 += inc0, i1 += inc1)
1958 if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
1959 return 0;
1960 return 1;
1961 case scm_tc7_uvect:
1962 case scm_tc7_ivect:
1963 {
1964 long *v0 = (long *) SCM_VELTS (ra0) + i0;
1965 long *v1 = (long *) SCM_VELTS (ra1) + i1;
1966 for (; n--; v0 += inc0, v1 += inc1)
1967 if (*v0 != *v1)
1968 return 0;
1969 return 1;
1970 }
1971#ifdef SCM_FLOATS
1972#ifdef SCM_SINGLES
1973 case scm_tc7_fvect:
1974 {
1975 float *v0 = (float *) SCM_VELTS (ra0) + i0;
1976 float *v1 = (float *) SCM_VELTS (ra1) + i1;
1977 for (; n--; v0 += inc0, v1 += inc1)
1978 if (*v0 != *v1)
1979 return 0;
1980 return 1;
1981 }
1982#endif /* SCM_SINGLES */
1983 case scm_tc7_dvect:
1984 {
1985 double *v0 = (double *) SCM_VELTS (ra0) + i0;
1986 double *v1 = (double *) SCM_VELTS (ra1) + i1;
1987 for (; n--; v0 += inc0, v1 += inc1)
1988 if (*v0 != *v1)
1989 return 0;
1990 return 1;
1991 }
1992 case scm_tc7_cvect:
1993 {
1994 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
1995 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
1996 for (; n--; v0 += inc0, v1 += inc1)
1997 {
1998 if ((*v0)[0] != (*v1)[0])
1999 return 0;
2000 if ((*v0)[1] != (*v1)[1])
2001 return 0;
2002 }
2003 return 1;
2004 }
2005#endif /* SCM_FLOATS */
2006 }
2007}
2008
2009
1cc91f1b
JB		 2010
2011static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
2012
0f2d19dd
JB		 2013static int
2014raeql (ra0, as_equal, ra1)
2015 SCM ra0;
2016 SCM as_equal;
2017 SCM ra1;
0f2d19dd
JB		 2018{
2019 SCM v0 = ra0, v1 = ra1;
2020 scm_array_dim dim0, dim1;
2021 scm_array_dim *s0 = &dim0, *s1 = &dim1;
2022 scm_sizet bas0 = 0, bas1 = 0;
2023 int k, unroll = 1, vlen = 1, ndim = 1;
2024 if SCM_ARRAYP
2025 (ra0)
2026 {
2027 ndim = SCM_ARRAY_NDIM (ra0);
2028 s0 = SCM_ARRAY_DIMS (ra0);
2029 bas0 = SCM_ARRAY_BASE (ra0);
2030 v0 = SCM_ARRAY_V (ra0);
2031 }
2032 else
2033 {
2034 s0->inc = 1;
2035 s0->lbnd = 0;
2036 s0->ubnd = SCM_LENGTH (v0) - 1;
2037 unroll = 0;
2038 }
2039 if SCM_ARRAYP
2040 (ra1)
2041 {
2042 if (ndim != SCM_ARRAY_NDIM (ra1))
2043 return 0;
2044 s1 = SCM_ARRAY_DIMS (ra1);
2045 bas1 = SCM_ARRAY_BASE (ra1);
2046 v1 = SCM_ARRAY_V (ra1);
2047 }
2048 else
2049 {
2050 if (1 != ndim)
2051 return SCM_BOOL_F;
2052 s1->inc = 1;
2053 s1->lbnd = 0;
2054 s1->ubnd = SCM_LENGTH (v1) - 1;
2055 unroll = 0;
2056 }
2057 if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
2058 return 0;
2059 for (k = ndim; k--;)
2060 {
2061 if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
2062 return 0;
2063 if (unroll)
2064 {
2065 unroll = (s0[k].inc == s1[k].inc);
2066 vlen *= s0[k].ubnd - s1[k].lbnd + 1;
2067 }
2068 }
2069 if (unroll && bas0 == bas1 && v0 == v1)
2070 return SCM_BOOL_T;
2071 return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
2072}
2073
1cc91f1b 2074
0f2d19dd
JB		 2075SCM
2076scm_raequal (ra0, ra1)
2077 SCM ra0;
2078 SCM ra1;
0f2d19dd
JB		 2079{
2080 return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
2081}
2082
2083static char s_array_equal_p[] = "array-equal?";
2084
1cc91f1b 2085
0f2d19dd
JB		 2086SCM
2087scm_array_equal_p (ra0, ra1)
2088 SCM ra0;
2089 SCM ra1;
0f2d19dd
JB		 2090{
2091 if (SCM_IMP (ra0) || SCM_IMP (ra1))
2092 callequal:return scm_equal_p (ra0, ra1);
2093 switch SCM_TYP7
2094 (ra0)
2095 {
2096 default:
2097 goto callequal;
2098 case scm_tc7_bvect:
2099 case scm_tc7_string:
b1d24656 2100 case scm_tc7_byvect:
0f2d19dd
JB		 2101 case scm_tc7_uvect:
2102 case scm_tc7_ivect:
2103 case scm_tc7_fvect:
2104 case scm_tc7_dvect:
2105 case scm_tc7_cvect:
2106 case scm_tc7_vector:
95f5b0f5 2107 case scm_tc7_wvect:
0f2d19dd
JB		 2108 break;
2109 case scm_tc7_smob:
2110 if (!SCM_ARRAYP (ra0))
2111 goto callequal;
2112 }
2113 switch SCM_TYP7
2114 (ra1)
2115 {
2116 default:
2117 goto callequal;
2118 case scm_tc7_bvect:
2119 case scm_tc7_string:
b1d24656 2120 case scm_tc7_byvect:
0f2d19dd
JB		 2121 case scm_tc7_uvect:
2122 case scm_tc7_ivect:
2123 case scm_tc7_fvect:
2124 case scm_tc7_dvect:
2125 case scm_tc7_cvect:
2126 case scm_tc7_vector:
95f5b0f5 2127 case scm_tc7_wvect:
0f2d19dd
JB		 2128 break;
2129 case scm_tc7_smob:
2130 if (!SCM_ARRAYP (ra1))
2131 goto callequal;
2132 }
2133 return (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
2134}
2135
2136
2137
1cc91f1b
JB		 2138static void
2139init_raprocs (subra)
0f2d19dd
JB		 2140 ra_iproc *subra;
2141{
2142 for (; subra->name; subra++)
2143 subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
2144}
2145
1cc91f1b 2146
0f2d19dd
JB		 2147void
2148scm_init_ramap ()
0f2d19dd
JB		 2149{
2150 init_raprocs (ra_rpsubrs);
2151 init_raprocs (ra_asubrs);
2152 scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
2153 scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
2154#include "ramap.x"
2155 scm_add_feature (s_array_for_each);
2156}
2157
2158#endif /* ARRAYS */
Unnamed repository; edit this file 'description' to name the repository.