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