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