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