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