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