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