HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
*** empty log message ***
[bpt/guile.git] / libguile / ramap.c
1 /* Copyright (C) 1996,1998,2000,2001,2004 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_to_long (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_to_ulong (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_to_ulong (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 length = scm_to_ulong (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_from_int (-1));
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_from_ulong (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 {
472 char *data = scm_i_string_writable_chars (ra);
473 for (i = base; n--; i += inc)
474 data[i] = SCM_CHAR (fill);
475 scm_i_string_stop_writing ();
476 }
477 break;
478 case scm_tc7_byvect:
479 if (SCM_CHARP (fill))
480 fill = SCM_I_MAKINUM ((signed char) SCM_CHAR (fill));
481 SCM_ASRTGO (SCM_I_INUMP (fill), badarg2);
482 SCM_ASSERT_RANGE (SCM_ARG2, fill,
483 -128 <= SCM_I_INUM (fill) && SCM_I_INUM (fill) < 128);
484 for (i = base; n--; i += inc)
485 ((char *) SCM_UVECTOR_BASE (ra))[i] = SCM_I_INUM (fill);
486 break;
487 case scm_tc7_bvect:
488 { /* scope */
489 long *ve = (long *) SCM_VELTS (ra);
490 if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_BITVECTOR_LENGTH (ra)))
491 {
492 i = base / SCM_LONG_BIT;
493 if (scm_is_false (fill))
494 {
495 if (base % SCM_LONG_BIT) /* leading partial word */
496 ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
497 for (; i < (base + n) / SCM_LONG_BIT; i++)
498 ve[i] = 0L;
499 if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
500 ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
501 }
502 else if (scm_is_eq (fill, SCM_BOOL_T))
503 {
504 if (base % SCM_LONG_BIT)
505 ve[i++] |= ~0L << (base % SCM_LONG_BIT);
506 for (; i < (base + n) / SCM_LONG_BIT; i++)
507 ve[i] = ~0L;
508 if ((base + n) % SCM_LONG_BIT)
509 ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
510 }
511 else
512 badarg2:SCM_WRONG_TYPE_ARG (2, fill);
513 }
514 else
515 {
516 if (scm_is_false (fill))
517 for (i = base; n--; i += inc)
518 ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
519 else if (scm_is_eq (fill, SCM_BOOL_T))
520 for (i = base; n--; i += inc)
521 ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
522 else
523 goto badarg2;
524 }
525 break;
526 }
527 case scm_tc7_uvect:
528 { /* scope */
529 unsigned long f = SCM_NUM2ULONG (2, fill);
530 unsigned long *ve = (unsigned long *) SCM_VELTS (ra);
531
532 for (i = base; n--; i += inc)
533 ve[i] = f;
534 break;
535 }
536 case scm_tc7_ivect:
537 { /* scope */
538 long f = SCM_NUM2LONG (2, fill);
539 long *ve = (long *) SCM_VELTS (ra);
540
541 for (i = base; n--; i += inc)
542 ve[i] = f;
543 break;
544 }
545 case scm_tc7_svect:
546 SCM_ASRTGO (SCM_I_INUMP (fill), badarg2);
547 { /* scope */
548 short f = SCM_I_INUM (fill);
549 short *ve = (short *) SCM_VELTS (ra);
550
551 if (f != SCM_I_INUM (fill))
552 SCM_OUT_OF_RANGE (2, fill);
553 for (i = base; n--; i += inc)
554 ve[i] = f;
555 break;
556 }
557 #if SCM_SIZEOF_LONG_LONG != 0
558 case scm_tc7_llvect:
559 { /* scope */
560 long long f = SCM_NUM2LONG_LONG (2, fill);
561 long long *ve = (long long *) SCM_VELTS (ra);
562
563 for (i = base; n--; i += inc)
564 ve[i] = f;
565 break;
566 }
567 #endif
568 case scm_tc7_fvect:
569 { /* scope */
570 float f, *ve = (float *) SCM_VELTS (ra);
571 f = (float) scm_to_double (fill);
572 for (i = base; n--; i += inc)
573 ve[i] = f;
574 break;
575 }
576 case scm_tc7_dvect:
577 { /* scope */
578 double f, *ve = (double *) SCM_VELTS (ra);
579 f = scm_to_double (fill);
580 for (i = base; n--; i += inc)
581 ve[i] = f;
582 break;
583 }
584 case scm_tc7_cvect:
585 { /* scope */
586 double fr, fi;
587 double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
588 SCM_ASRTGO (SCM_INEXACTP (fill), badarg2);
589 if (SCM_REALP (fill)) {
590 fr = SCM_REAL_VALUE (fill);
591 fi = 0.0;
592 } else {
593 fr = SCM_COMPLEX_REAL (fill);
594 fi = SCM_COMPLEX_IMAG (fill);
595 }
596 for (i = base; n--; i += inc)
597 {
598 ve[i][0] = fr;
599 ve[i][1] = fi;
600 }
601 break;
602 }
603 }
604 return 1;
605 }
606 #undef FUNC_NAME
607
608
609
610 static int
611 racp (SCM src, SCM dst)
612 {
613 long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
614 long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
615 unsigned long i_d, i_s = SCM_ARRAY_BASE (src);
616 dst = SCM_CAR (dst);
617 inc_d = SCM_ARRAY_DIMS (dst)->inc;
618 i_d = SCM_ARRAY_BASE (dst);
619 src = SCM_ARRAY_V (src);
620 dst = SCM_ARRAY_V (dst);
621
622 switch SCM_TYP7 (dst)
623 {
624 default:
625 gencase:
626 case scm_tc7_vector:
627 case scm_tc7_wvect:
628
629 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
630 scm_array_set_x (dst,
631 scm_cvref (src, i_s, SCM_UNDEFINED),
632 scm_from_ulong (i_d));
633 break;
634 case scm_tc7_string:
635 if (SCM_TYP7 (src) != scm_tc7_string)
636 goto gencase;
637 {
638 char *dst_data = scm_i_string_writable_chars (dst);
639 const char *src_data = scm_i_string_chars (src);
640 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
641 dst_data[i_d] = src_data[i_s];
642 scm_i_string_stop_writing ();
643 }
644 break;
645 case scm_tc7_byvect:
646 if (SCM_TYP7 (src) != scm_tc7_byvect)
647 goto gencase;
648 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
649 ((char *) SCM_UVECTOR_BASE (dst))[i_d]
650 = ((char *) SCM_UVECTOR_BASE (src))[i_s];
651 break;
652 case scm_tc7_bvect:
653 if (SCM_TYP7 (src) != scm_tc7_bvect)
654 goto gencase;
655 if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
656 {
657 long *sv = (long *) SCM_VELTS (src);
658 long *dv = (long *) SCM_VELTS (dst);
659 sv += i_s / SCM_LONG_BIT;
660 dv += i_d / SCM_LONG_BIT;
661 if (i_s % SCM_LONG_BIT)
662 { /* leading partial word */
663 *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
664 dv++;
665 sv++;
666 n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
667 }
668 IVDEP (src != dst,
669 for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
670 *dv = *sv;)
671 if (n) /* trailing partial word */
672 *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
673 }
674 else
675 {
676 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
677 if (SCM_BITVEC_REF(src, i_s))
678 SCM_BITVEC_SET(dst, i_d);
679 else
680 SCM_BITVEC_CLR(dst, i_d);
681 }
682 break;
683 case scm_tc7_uvect:
684 if (scm_tc7_uvect != SCM_TYP7 (src))
685 goto gencase;
686 else
687 {
688 long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
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 }
694 case scm_tc7_ivect:
695 if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
696 goto gencase;
697 else
698 {
699 long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
700 IVDEP (src != dst,
701 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
702 d[i_d] = s[i_s];)
703 break;
704 }
705 case scm_tc7_fvect:
706 {
707 float *d = (float *) SCM_VELTS (dst);
708 float *s = (float *) SCM_VELTS (src);
709 switch SCM_TYP7
710 (src)
711 {
712 default:
713 goto gencase;
714 case scm_tc7_ivect:
715 case scm_tc7_uvect:
716 IVDEP (src != dst,
717 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
718 d[i_d] = ((long *) s)[i_s];)
719 break;
720 case scm_tc7_fvect:
721 IVDEP (src != dst,
722 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
723 d[i_d] = s[i_s];)
724 break;
725 case scm_tc7_dvect:
726 IVDEP (src !=dst,
727 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
728 d[i_d] = ((double *) s)[i_s];)
729 break;
730 }
731 break;
732 }
733 case scm_tc7_dvect:
734 {
735 double *d = (double *) SCM_VELTS (dst);
736 double *s = (double *) SCM_VELTS (src);
737 switch SCM_TYP7
738 (src)
739 {
740 default:
741 goto gencase;
742 case scm_tc7_ivect:
743 case scm_tc7_uvect:
744 IVDEP (src != dst,
745 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
746 d[i_d] = ((long *) s)[i_s];)
747 break;
748 case scm_tc7_fvect:
749 IVDEP (src != dst,
750 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
751 d[i_d] = ((float *) s)[i_s];)
752 break;
753 case scm_tc7_dvect:
754 IVDEP (src != dst,
755 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
756 d[i_d] = s[i_s];)
757 break;
758 }
759 break;
760 }
761 case scm_tc7_cvect:
762 {
763 double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
764 double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
765 switch SCM_TYP7
766 (src)
767 {
768 default:
769 goto gencase;
770 case scm_tc7_ivect:
771 case scm_tc7_uvect:
772 IVDEP (src != dst,
773 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
774 {
775 d[i_d][0] = ((long *) s)[i_s];
776 d[i_d][1] = 0.0;
777 })
778 break;
779 case scm_tc7_fvect:
780 IVDEP (src != dst,
781 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
782 {
783 d[i_d][0] = ((float *) s)[i_s];
784 d[i_d][1] = 0.0;
785 })
786 break;
787 case scm_tc7_dvect:
788 IVDEP (src != dst,
789 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
790 {
791 d[i_d][0] = ((double *) s)[i_s];
792 d[i_d][1] = 0.0;
793 })
794 break;
795 case scm_tc7_cvect:
796 IVDEP (src != dst,
797 for (; n-- > 0; i_s += inc_s, i_d += inc_d)
798 {
799 d[i_d][0] = s[i_s][0];
800 d[i_d][1] = s[i_s][1];
801 })
802 }
803 break;
804 }
805 }
806 return 1;
807 }
808
809
810 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
811
812
813 SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
814 (SCM src, SCM dst),
815 "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
816 "Copy every element from vector or array @var{source} to the\n"
817 "corresponding element of @var{destination}. @var{destination} must have\n"
818 "the same rank as @var{source}, and be at least as large in each\n"
819 "dimension. The order is unspecified.")
820 #define FUNC_NAME s_scm_array_copy_x
821 {
822 scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
823 return SCM_UNSPECIFIED;
824 }
825 #undef FUNC_NAME
826
827 /* Functions callable by ARRAY-MAP! */
828
829
830 int
831 scm_ra_eqp (SCM ra0, SCM ras)
832 {
833 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
834 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
835 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
836 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
837 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
838 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
839 ra0 = SCM_ARRAY_V (ra0);
840 ra1 = SCM_ARRAY_V (ra1);
841 ra2 = SCM_ARRAY_V (ra2);
842 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
843 {
844 default:
845 {
846 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
847 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
848 if (SCM_BITVEC_REF (ra0, i0))
849 if (scm_is_false(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
850 SCM_BITVEC_CLR (ra0, i0);
851 break;
852 }
853 case scm_tc7_uvect:
854 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
855 if (SCM_BITVEC_REF (ra0, i0))
856 if (((unsigned long *) SCM_VELTS (ra1))[i1] != ((unsigned long *) SCM_VELTS (ra2))[i2])
857 SCM_BITVEC_CLR (ra0, i0);
858 break;
859 case scm_tc7_ivect:
860 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
861 if (SCM_BITVEC_REF (ra0, i0))
862 if (((signed long *) SCM_VELTS (ra1))[i1] != ((signed long *) SCM_VELTS (ra2))[i2])
863 SCM_BITVEC_CLR (ra0, i0);
864 break;
865 case scm_tc7_fvect:
866 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
867 if (SCM_BITVEC_REF (ra0, i0))
868 if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
869 SCM_BITVEC_CLR (ra0, i0);
870 break;
871 case scm_tc7_dvect:
872 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
873 if (SCM_BITVEC_REF (ra0, i0))
874 if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
875 SCM_BITVEC_CLR (ra0, i0);
876 break;
877 case scm_tc7_cvect:
878 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
879 if (SCM_BITVEC_REF (ra0, i0))
880 if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
881 ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
882 SCM_BITVEC_CLR (ra0, i0);
883 break;
884 }
885 return 1;
886 }
887
888 /* opt 0 means <, nonzero means >= */
889
890 static int
891 ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
892 {
893 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
894 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
895 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
896 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
897 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
898 ra0 = SCM_ARRAY_V (ra0);
899 ra1 = SCM_ARRAY_V (ra1);
900 ra2 = SCM_ARRAY_V (ra2);
901 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
902 {
903 default:
904 {
905 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
906 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
907 if (SCM_BITVEC_REF (ra0, i0))
908 if (opt ?
909 scm_is_true (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
910 scm_is_false (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
911 SCM_BITVEC_CLR (ra0, i0);
912 break;
913 }
914 case scm_tc7_uvect:
915 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
916 {
917 if (SCM_BITVEC_REF (ra0, i0))
918 if (opt ?
919 ((unsigned long *) SCM_VELTS (ra1))[i1] < ((unsigned long *) SCM_VELTS (ra2))[i2] :
920 ((unsigned long *) SCM_VELTS (ra1))[i1] >= ((unsigned long *) SCM_VELTS (ra2))[i2])
921 SCM_BITVEC_CLR (ra0, i0);
922 }
923 break;
924 case scm_tc7_ivect:
925 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
926 {
927 if (SCM_BITVEC_REF (ra0, i0))
928 if (opt ?
929 ((signed long *) SCM_VELTS (ra1))[i1] < ((signed long *) SCM_VELTS (ra2))[i2] :
930 ((signed long *) SCM_VELTS (ra1))[i1] >= ((signed long *) SCM_VELTS (ra2))[i2])
931 SCM_BITVEC_CLR (ra0, i0);
932 }
933 break;
934 case scm_tc7_fvect:
935 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
936 if (SCM_BITVEC_REF(ra0, i0))
937 if (opt ?
938 ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
939 ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
940 SCM_BITVEC_CLR (ra0, i0);
941 break;
942 case scm_tc7_dvect:
943 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
944 if (SCM_BITVEC_REF (ra0, i0))
945 if (opt ?
946 ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
947 ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
948 SCM_BITVEC_CLR (ra0, i0);
949 break;
950 }
951 return 1;
952 }
953
954
955
956 int
957 scm_ra_lessp (SCM ra0, SCM ras)
958 {
959 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
960 }
961
962
963 int
964 scm_ra_leqp (SCM ra0, SCM ras)
965 {
966 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
967 }
968
969
970 int
971 scm_ra_grp (SCM ra0, SCM ras)
972 {
973 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
974 }
975
976
977 int
978 scm_ra_greqp (SCM ra0, SCM ras)
979 {
980 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
981 }
982
983
984 int
985 scm_ra_sum (SCM ra0, SCM ras)
986 {
987 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
988 unsigned long i0 = SCM_ARRAY_BASE (ra0);
989 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
990 ra0 = SCM_ARRAY_V (ra0);
991 if (!scm_is_null(ras))
992 {
993 SCM ra1 = SCM_CAR (ras);
994 unsigned long i1 = SCM_ARRAY_BASE (ra1);
995 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
996 ra1 = SCM_ARRAY_V (ra1);
997 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
998 {
999 default:
1000 {
1001 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1002 for (; n-- > 0; i0 += inc0, i1 += inc1)
1003 scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1004 scm_from_ulong (i0));
1005 break;
1006 }
1007 case scm_tc7_uvect:
1008 case scm_tc7_ivect:
1009 BINARY_ELTS_CODE( +=, long);
1010 case scm_tc7_fvect:
1011 BINARY_ELTS_CODE( +=, float);
1012 case scm_tc7_dvect:
1013 BINARY_ELTS_CODE( +=, double);
1014 case scm_tc7_cvect:
1015 BINARY_PAIR_ELTS_CODE( +=, double);
1016 }
1017 }
1018 return 1;
1019 }
1020
1021
1022
1023 int
1024 scm_ra_difference (SCM ra0, SCM ras)
1025 {
1026 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1027 unsigned long i0 = SCM_ARRAY_BASE (ra0);
1028 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1029 ra0 = SCM_ARRAY_V (ra0);
1030 if (scm_is_null (ras))
1031 {
1032 switch (SCM_TYP7 (ra0))
1033 {
1034 default:
1035 {
1036 SCM e0 = SCM_UNDEFINED;
1037 for (; n-- > 0; i0 += inc0)
1038 scm_array_set_x (ra0,
1039 scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED),
1040 scm_from_ulong (i0));
1041 break;
1042 }
1043 case scm_tc7_fvect:
1044 UNARY_ELTS_CODE( = -, float);
1045 case scm_tc7_dvect:
1046 UNARY_ELTS_CODE( = -, double);
1047 case scm_tc7_cvect:
1048 UNARY_PAIR_ELTS_CODE( = -, double);
1049 }
1050 }
1051 else
1052 {
1053 SCM ra1 = SCM_CAR (ras);
1054 unsigned long i1 = SCM_ARRAY_BASE (ra1);
1055 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1056 ra1 = SCM_ARRAY_V (ra1);
1057 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1058 {
1059 default:
1060 {
1061 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1062 for (; n-- > 0; i0 += inc0, i1 += inc1)
1063 scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), scm_from_ulong (i0));
1064 break;
1065 }
1066 case scm_tc7_fvect:
1067 BINARY_ELTS_CODE( -=, float);
1068 case scm_tc7_dvect:
1069 BINARY_ELTS_CODE( -=, double);
1070 case scm_tc7_cvect:
1071 BINARY_PAIR_ELTS_CODE( -=, double);
1072 }
1073 }
1074 return 1;
1075 }
1076
1077
1078
1079 int
1080 scm_ra_product (SCM ra0, SCM ras)
1081 {
1082 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1083 unsigned long i0 = SCM_ARRAY_BASE (ra0);
1084 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1085 ra0 = SCM_ARRAY_V (ra0);
1086 if (!scm_is_null (ras))
1087 {
1088 SCM ra1 = SCM_CAR (ras);
1089 unsigned long i1 = SCM_ARRAY_BASE (ra1);
1090 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1091 ra1 = SCM_ARRAY_V (ra1);
1092 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1093 {
1094 default:
1095 {
1096 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1097 for (; n-- > 0; i0 += inc0, i1 += inc1)
1098 scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1099 scm_from_ulong (i0));
1100 break;
1101 }
1102 case scm_tc7_uvect:
1103 case scm_tc7_ivect:
1104 BINARY_ELTS_CODE( *=, long);
1105 case scm_tc7_fvect:
1106 BINARY_ELTS_CODE( *=, float);
1107 case scm_tc7_dvect:
1108 BINARY_ELTS_CODE( *=, double);
1109 case scm_tc7_cvect:
1110 {
1111 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1112 register double r;
1113 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1114 IVDEP (ra0 != ra1,
1115 for (; n-- > 0; i0 += inc0, i1 += inc1)
1116 {
1117 r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
1118 v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
1119 v0[i0][0] = r;
1120 }
1121 );
1122 break;
1123 }
1124 }
1125 }
1126 return 1;
1127 }
1128
1129
1130 int
1131 scm_ra_divide (SCM ra0, SCM ras)
1132 {
1133 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1134 unsigned long i0 = SCM_ARRAY_BASE (ra0);
1135 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1136 ra0 = SCM_ARRAY_V (ra0);
1137 if (scm_is_null (ras))
1138 {
1139 switch (SCM_TYP7 (ra0))
1140 {
1141 default:
1142 {
1143 SCM e0 = SCM_UNDEFINED;
1144 for (; n-- > 0; i0 += inc0)
1145 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), scm_from_ulong (i0));
1146 break;
1147 }
1148 case scm_tc7_fvect:
1149 UNARY_ELTS_CODE( = 1.0 / , float);
1150 case scm_tc7_dvect:
1151 UNARY_ELTS_CODE( = 1.0 / , double);
1152 case scm_tc7_cvect:
1153 {
1154 register double d;
1155 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1156 for (; n-- > 0; i0 += inc0)
1157 {
1158 d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
1159 v0[i0][0] /= d;
1160 v0[i0][1] /= -d;
1161 }
1162 break;
1163 }
1164 }
1165 }
1166 else
1167 {
1168 SCM ra1 = SCM_CAR (ras);
1169 unsigned long i1 = SCM_ARRAY_BASE (ra1);
1170 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1171 ra1 = SCM_ARRAY_V (ra1);
1172 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1173 {
1174 default:
1175 {
1176 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1177 for (; n-- > 0; i0 += inc0, i1 += inc1)
1178 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), scm_from_ulong (i0));
1179 break;
1180 }
1181 case scm_tc7_fvect:
1182 BINARY_ELTS_CODE( /=, float);
1183 case scm_tc7_dvect:
1184 BINARY_ELTS_CODE( /=, double);
1185 case scm_tc7_cvect:
1186 {
1187 register double d, r;
1188 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1189 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1190 IVDEP (ra0 != ra1,
1191 for (; n-- > 0; i0 += inc0, i1 += inc1)
1192 {
1193 d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
1194 r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
1195 v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
1196 v0[i0][0] = r;
1197 }
1198 )
1199 break;
1200 }
1201 }
1202 }
1203 return 1;
1204 }
1205
1206
1207 int
1208 scm_array_identity (SCM dst, SCM src)
1209 {
1210 return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
1211 }
1212
1213
1214
1215 static int
1216 ramap (SCM ra0, SCM proc, SCM ras)
1217 {
1218 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1219 long inc = SCM_ARRAY_DIMS (ra0)->inc;
1220 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1221 long base = SCM_ARRAY_BASE (ra0) - i * inc;
1222 ra0 = SCM_ARRAY_V (ra0);
1223 if (scm_is_null (ras))
1224 for (; i <= n; i++)
1225 scm_array_set_x (ra0, scm_call_0 (proc), scm_from_long (i * inc + base));
1226 else
1227 {
1228 SCM ra1 = SCM_CAR (ras);
1229 SCM args;
1230 SCM const *ve = &ras;
1231 unsigned long k, i1 = SCM_ARRAY_BASE (ra1);
1232 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1233 ra1 = SCM_ARRAY_V (ra1);
1234 ras = SCM_CDR (ras);
1235 if (scm_is_null(ras))
1236 ras = scm_nullvect;
1237 else
1238 {
1239 ras = scm_vector (ras);
1240 ve = SCM_VELTS (ras);
1241 }
1242
1243 for (; i <= n; i++, i1 += inc1)
1244 {
1245 args = SCM_EOL;
1246 for (k = scm_to_ulong (scm_uniform_vector_length (ras)); k--;)
1247 args = scm_cons (scm_uniform_vector_ref (ve[k], scm_from_long (i)), args);
1248 args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1249 scm_array_set_x (ra0, scm_apply_0 (proc, args), scm_from_long (i * inc + base));
1250 }
1251 }
1252 return 1;
1253 }
1254
1255
1256 static int
1257 ramap_dsubr (SCM ra0, SCM proc, SCM ras)
1258 {
1259 SCM ra1 = SCM_CAR (ras);
1260 SCM e1 = SCM_UNDEFINED;
1261 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1262 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1263 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1;
1264 ra0 = SCM_ARRAY_V (ra0);
1265 ra1 = SCM_ARRAY_V (ra1);
1266 switch (SCM_TYP7 (ra0))
1267 {
1268 default:
1269 gencase:
1270 for (; n-- > 0; i0 += inc0, i1 += inc1)
1271 scm_array_set_x (ra0, scm_call_1 (proc, RVREF (ra1, i1, e1)), scm_from_ulong (i0));
1272 break;
1273 case scm_tc7_fvect:
1274 {
1275 float *dst = (float *) SCM_VELTS (ra0);
1276 switch (SCM_TYP7 (ra1))
1277 {
1278 default:
1279 goto gencase;
1280 case scm_tc7_fvect:
1281 for (; n-- > 0; i0 += inc0, i1 += inc1)
1282 dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
1283 break;
1284 case scm_tc7_uvect:
1285 case scm_tc7_ivect:
1286 for (; n-- > 0; i0 += inc0, i1 += inc1)
1287 dst[i0] = SCM_DSUBRF (proc) (SCM_UNPACK (SCM_VELTS (ra1)[i1]));
1288 break;
1289 }
1290 break;
1291 }
1292 case scm_tc7_dvect:
1293 {
1294 double *dst = (double *) SCM_VELTS (ra0);
1295 switch (SCM_TYP7 (ra1))
1296 {
1297 default:
1298 goto gencase;
1299 case scm_tc7_dvect:
1300 for (; n-- > 0; i0 += inc0, i1 += inc1)
1301 dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
1302 break;
1303 case scm_tc7_uvect:
1304 case scm_tc7_ivect:
1305 for (; n-- > 0; i0 += inc0, i1 += inc1)
1306 dst[i0] = SCM_DSUBRF (proc) (SCM_UNPACK (SCM_VELTS (ra1)[i1]));
1307 break;
1308 }
1309 break;
1310 }
1311 }
1312 return 1;
1313 }
1314
1315
1316
1317 static int
1318 ramap_rp (SCM ra0, SCM proc, SCM ras)
1319 {
1320 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
1321 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
1322 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1323 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
1324 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1325 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1326 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
1327 ra0 = SCM_ARRAY_V (ra0);
1328 ra1 = SCM_ARRAY_V (ra1);
1329 ra2 = SCM_ARRAY_V (ra2);
1330 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
1331 {
1332 default:
1333 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1334 if (SCM_BITVEC_REF (ra0, i0))
1335 if (scm_is_false (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
1336 SCM_BITVEC_CLR (ra0, i0);
1337 break;
1338 case scm_tc7_uvect:
1339 case scm_tc7_ivect:
1340 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1341 if (SCM_BITVEC_REF (ra0, i0))
1342 {
1343 /* DIRK:FIXME:: There should be a way to access the elements
1344 of a cell as raw data.
1345 */
1346 SCM n1 = scm_from_long (((long *) SCM_UNPACK (SCM_CDR (ra1)))[i1]);
1347 SCM n2 = scm_from_long (((long *) SCM_UNPACK (SCM_CDR (ra2)))[i2]);
1348 if (scm_is_false (SCM_SUBRF (proc) (n1, n2)))
1349 SCM_BITVEC_CLR (ra0, i0);
1350 }
1351 break;
1352 case scm_tc7_fvect:
1353 {
1354 SCM a1 = scm_from_double (1.0), a2 = scm_from_double (1.0);
1355 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1356 if (SCM_BITVEC_REF (ra0, i0))
1357 {
1358 SCM_REAL_VALUE (a1) = ((float *) SCM_VELTS (ra1))[i1];
1359 SCM_REAL_VALUE (a2) = ((float *) SCM_VELTS (ra2))[i2];
1360 if (scm_is_false (SCM_SUBRF (proc) (a1, a2)))
1361 SCM_BITVEC_CLR (ra0, i0);
1362 }
1363 break;
1364 }
1365 case scm_tc7_dvect:
1366 {
1367 SCM a1 = scm_from_double (1.0 / 3.0);
1368 SCM a2 = scm_from_double (1.0 / 3.0);
1369 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1370 if (SCM_BITVEC_REF (ra0, i0))
1371 {
1372 SCM_REAL_VALUE (a1) = ((double *) SCM_VELTS (ra1))[i1];
1373 SCM_REAL_VALUE (a2) = ((double *) SCM_VELTS (ra2))[i2];
1374 if (scm_is_false (SCM_SUBRF (proc) (a1, a2)))
1375 SCM_BITVEC_CLR (ra0, i0);
1376 }
1377 break;
1378 }
1379 case scm_tc7_cvect:
1380 {
1381 SCM a1 = scm_c_make_rectangular (1.0, 1.0);
1382 SCM a2 = scm_c_make_rectangular (1.0, 1.0);
1383 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1384 if (SCM_BITVEC_REF (ra0, i0))
1385 {
1386 SCM_COMPLEX_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
1387 SCM_COMPLEX_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
1388 SCM_COMPLEX_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
1389 SCM_COMPLEX_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
1390 if (scm_is_false (SCM_SUBRF (proc) (a1, a2)))
1391 SCM_BITVEC_CLR (ra0, i0);
1392 }
1393 break;
1394 }
1395 }
1396 return 1;
1397 }
1398
1399
1400
1401 static int
1402 ramap_1 (SCM ra0, SCM proc, SCM ras)
1403 {
1404 SCM ra1 = SCM_CAR (ras);
1405 SCM e1 = SCM_UNDEFINED;
1406 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1407 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1408 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1409 ra0 = SCM_ARRAY_V (ra0);
1410 ra1 = SCM_ARRAY_V (ra1);
1411 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
1412 for (; n-- > 0; i0 += inc0, i1 += inc1)
1413 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), scm_from_ulong (i0));
1414 else
1415 for (; n-- > 0; i0 += inc0, i1 += inc1)
1416 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), scm_from_ulong (i0));
1417 return 1;
1418 }
1419
1420
1421
1422 static int
1423 ramap_2o (SCM ra0, SCM proc, SCM ras)
1424 {
1425 SCM ra1 = SCM_CAR (ras);
1426 SCM e1 = SCM_UNDEFINED;
1427 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1428 unsigned long i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1429 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1430 ra0 = SCM_ARRAY_V (ra0);
1431 ra1 = SCM_ARRAY_V (ra1);
1432 ras = SCM_CDR (ras);
1433 if (scm_is_null (ras))
1434 {
1435 if (scm_tc7_vector == SCM_TYP7 (ra0)
1436 || scm_tc7_wvect == SCM_TYP7 (ra0))
1437
1438 for (; n-- > 0; i0 += inc0, i1 += inc1)
1439 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
1440 scm_from_ulong (i0));
1441 else
1442 for (; n-- > 0; i0 += inc0, i1 += inc1)
1443 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
1444 scm_from_ulong (i0));
1445 }
1446 else
1447 {
1448 SCM ra2 = SCM_CAR (ras);
1449 SCM e2 = SCM_UNDEFINED;
1450 unsigned long i2 = SCM_ARRAY_BASE (ra2);
1451 long inc2 = SCM_ARRAY_DIMS (ra2)->inc;
1452 ra2 = SCM_ARRAY_V (ra2);
1453 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
1454 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1455 scm_array_set_x (ra0,
1456 SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
1457 scm_from_ulong (i0));
1458 else
1459 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1460 scm_array_set_x (ra0,
1461 SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
1462 scm_from_ulong (i0));
1463 }
1464 return 1;
1465 }
1466
1467
1468
1469 static int
1470 ramap_a (SCM ra0, SCM proc, SCM ras)
1471 {
1472 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1473 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1474 unsigned long i0 = SCM_ARRAY_BASE (ra0);
1475 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1476 ra0 = SCM_ARRAY_V (ra0);
1477 if (scm_is_null (ras))
1478 for (; n-- > 0; i0 += inc0)
1479 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), scm_from_ulong (i0));
1480 else
1481 {
1482 SCM ra1 = SCM_CAR (ras);
1483 unsigned long i1 = SCM_ARRAY_BASE (ra1);
1484 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1485 ra1 = SCM_ARRAY_V (ra1);
1486 for (; n-- > 0; i0 += inc0, i1 += inc1)
1487 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1488 scm_from_ulong (i0));
1489 }
1490 return 1;
1491 }
1492
1493
1494 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
1495
1496
1497 SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
1498 (SCM ra0, SCM proc, SCM lra),
1499 "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
1500 "@var{array1}, @dots{} must have the same number of dimensions as\n"
1501 "@var{array0} and have a range for each index which includes the range\n"
1502 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
1503 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
1504 "as the corresponding element in @var{array0}. The value returned is\n"
1505 "unspecified. The order of application is unspecified.")
1506 #define FUNC_NAME s_scm_array_map_x
1507 {
1508 SCM_VALIDATE_PROC (2, proc);
1509 SCM_VALIDATE_REST_ARGUMENT (lra);
1510 switch (SCM_TYP7 (proc))
1511 {
1512 default:
1513 gencase:
1514 scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
1515 return SCM_UNSPECIFIED;
1516 case scm_tc7_subr_1:
1517 scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
1518 return SCM_UNSPECIFIED;
1519 case scm_tc7_subr_2:
1520 case scm_tc7_subr_2o:
1521 scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
1522 return SCM_UNSPECIFIED;
1523 case scm_tc7_dsubr:
1524 scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
1525 return SCM_UNSPECIFIED;
1526 case scm_tc7_rpsubr:
1527 {
1528 ra_iproc *p;
1529 if (scm_is_false (scm_array_p (ra0, SCM_BOOL_T)))
1530 goto gencase;
1531 scm_array_fill_x (ra0, SCM_BOOL_T);
1532 for (p = ra_rpsubrs; p->name; p++)
1533 if (scm_is_eq (proc, p->sproc))
1534 {
1535 while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
1536 {
1537 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
1538 lra = SCM_CDR (lra);
1539 }
1540 return SCM_UNSPECIFIED;
1541 }
1542 while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
1543 {
1544 scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
1545 lra = SCM_CDR (lra);
1546 }
1547 return SCM_UNSPECIFIED;
1548 }
1549 case scm_tc7_asubr:
1550 if (scm_is_null (lra))
1551 {
1552 SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
1553 if (SCM_I_INUMP(fill))
1554 {
1555 prot = scm_array_prototype (ra0);
1556 if (SCM_INEXACTP (prot))
1557 fill = scm_from_double ((double) SCM_I_INUM (fill));
1558 }
1559
1560 scm_array_fill_x (ra0, fill);
1561 }
1562 else
1563 {
1564 SCM tail, ra1 = SCM_CAR (lra);
1565 SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
1566 ra_iproc *p;
1567 /* Check to see if order might matter.
1568 This might be an argument for a separate
1569 SERIAL-ARRAY-MAP! */
1570 if (scm_is_eq (v0, ra1)
1571 || (SCM_ARRAYP (ra1) && scm_is_eq (v0, SCM_ARRAY_V (ra1))))
1572 if (!scm_is_eq (ra0, ra1)
1573 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
1574 goto gencase;
1575 for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
1576 {
1577 ra1 = SCM_CAR (tail);
1578 if (scm_is_eq (v0, ra1)
1579 || (SCM_ARRAYP (ra1) && scm_is_eq (v0, SCM_ARRAY_V (ra1))))
1580 goto gencase;
1581 }
1582 for (p = ra_asubrs; p->name; p++)
1583 if (scm_is_eq (proc, p->sproc))
1584 {
1585 if (!scm_is_eq (ra0, SCM_CAR (lra)))
1586 scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
1587 lra = SCM_CDR (lra);
1588 while (1)
1589 {
1590 scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
1591 if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
1592 return SCM_UNSPECIFIED;
1593 lra = SCM_CDR (lra);
1594 }
1595 }
1596 scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
1597 lra = SCM_CDR (lra);
1598 if (SCM_NIMP (lra))
1599 for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
1600 scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
1601 }
1602 return SCM_UNSPECIFIED;
1603 }
1604 }
1605 #undef FUNC_NAME
1606
1607
1608 static int
1609 rafe (SCM ra0, SCM proc, SCM ras)
1610 {
1611 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1612 unsigned long i0 = SCM_ARRAY_BASE (ra0);
1613 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1614 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1615 ra0 = SCM_ARRAY_V (ra0);
1616 if (scm_is_null (ras))
1617 for (; i <= n; i++, i0 += inc0)
1618 scm_call_1 (proc, scm_cvref (ra0, i0, SCM_UNDEFINED));
1619 else
1620 {
1621 SCM ra1 = SCM_CAR (ras);
1622 SCM args;
1623 SCM const*ve = &ras;
1624 unsigned long k, i1 = SCM_ARRAY_BASE (ra1);
1625 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1626 ra1 = SCM_ARRAY_V (ra1);
1627 ras = SCM_CDR (ras);
1628 if (scm_is_null(ras))
1629 ras = scm_nullvect;
1630 else
1631 {
1632 ras = scm_vector (ras);
1633 ve = SCM_VELTS (ras);
1634 }
1635 for (; i <= n; i++, i0 += inc0, i1 += inc1)
1636 {
1637 args = SCM_EOL;
1638 for (k = scm_to_ulong (scm_uniform_vector_length (ras)); k--;)
1639 args = scm_cons (scm_uniform_vector_ref (ve[k], scm_from_long (i)), args);
1640 args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1641 scm_apply_0 (proc, args);
1642 }
1643 }
1644 return 1;
1645 }
1646
1647
1648 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
1649 (SCM proc, SCM ra0, SCM lra),
1650 "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
1651 "in row-major order. The value returned is unspecified.")
1652 #define FUNC_NAME s_scm_array_for_each
1653 {
1654 SCM_VALIDATE_PROC (1, proc);
1655 SCM_VALIDATE_REST_ARGUMENT (lra);
1656 scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
1657 return SCM_UNSPECIFIED;
1658 }
1659 #undef FUNC_NAME
1660
1661 SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
1662 (SCM ra, SCM proc),
1663 "Apply @var{proc} to the indices of each element of @var{array} in\n"
1664 "turn, storing the result in the corresponding element. The value\n"
1665 "returned and the order of application are unspecified.\n\n"
1666 "One can implement @var{array-indexes} as\n"
1667 "@lisp\n"
1668 "(define (array-indexes array)\n"
1669 " (let ((ra (apply make-array #f (array-shape array))))\n"
1670 " (array-index-map! ra (lambda x x))\n"
1671 " ra))\n"
1672 "@end lisp\n"
1673 "Another example:\n"
1674 "@lisp\n"
1675 "(define (apl:index-generator n)\n"
1676 " (let ((v (make-uniform-vector n 1)))\n"
1677 " (array-index-map! v (lambda (i) i))\n"
1678 " v))\n"
1679 "@end lisp")
1680 #define FUNC_NAME s_scm_array_index_map_x
1681 {
1682 unsigned long i;
1683 SCM_VALIDATE_NIM (1, ra);
1684 SCM_VALIDATE_PROC (2, proc);
1685 switch (SCM_TYP7(ra))
1686 {
1687 default:
1688 badarg:SCM_WRONG_TYPE_ARG (1, ra);
1689 case scm_tc7_vector:
1690 case scm_tc7_wvect:
1691 {
1692 for (i = 0; i < SCM_VECTOR_LENGTH (ra); i++)
1693 SCM_VECTOR_SET(ra, i, scm_call_1 (proc, scm_from_long (i)));
1694 return SCM_UNSPECIFIED;
1695 }
1696 case scm_tc7_string:
1697 case scm_tc7_byvect:
1698 case scm_tc7_bvect:
1699 case scm_tc7_uvect:
1700 case scm_tc7_ivect:
1701 case scm_tc7_svect:
1702 #if SCM_SIZEOF_LONG_LONG != 0
1703 case scm_tc7_llvect:
1704 #endif
1705 case scm_tc7_fvect:
1706 case scm_tc7_dvect:
1707 case scm_tc7_cvect:
1708 {
1709 unsigned long int length = scm_to_ulong (scm_uniform_vector_length (ra));
1710 for (i = 0; i < length; i++)
1711 scm_array_set_x (ra, scm_call_1 (proc, scm_from_ulong (i)),
1712 scm_from_ulong (i));
1713 return SCM_UNSPECIFIED;
1714 }
1715 case scm_tc7_smob:
1716 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
1717 {
1718 SCM args = SCM_EOL;
1719 SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), scm_from_int (-1));
1720 long *vinds = (long *) SCM_VELTS (inds);
1721 int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
1722 if (kmax < 0)
1723 return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
1724 for (k = 0; k <= kmax; k++)
1725 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1726 k = kmax;
1727 do
1728 {
1729 if (k == kmax)
1730 {
1731 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1732 i = cind (ra, inds);
1733 for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
1734 {
1735 for (j = kmax + 1, args = SCM_EOL; j--;)
1736 args = scm_cons (scm_from_long (vinds[j]), args);
1737 scm_array_set_x (SCM_ARRAY_V (ra),
1738 scm_apply_0 (proc, args),
1739 scm_from_ulong (i));
1740 i += SCM_ARRAY_DIMS (ra)[k].inc;
1741 }
1742 k--;
1743 continue;
1744 }
1745 if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd)
1746 {
1747 vinds[k]++;
1748 k++;
1749 continue;
1750 }
1751 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1;
1752 k--;
1753 }
1754 while (k >= 0);
1755 return SCM_UNSPECIFIED;
1756 }
1757 }
1758 }
1759 #undef FUNC_NAME
1760
1761
1762 static int
1763 raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
1764 {
1765 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1766 unsigned long i0 = 0, i1 = 0;
1767 long inc0 = 1, inc1 = 1;
1768 unsigned long n;
1769 ra1 = SCM_CAR (ra1);
1770 if (SCM_ARRAYP(ra0))
1771 {
1772 n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1773 i0 = SCM_ARRAY_BASE (ra0);
1774 inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1775 ra0 = SCM_ARRAY_V (ra0);
1776 }
1777 else
1778 n = scm_to_ulong (scm_uniform_vector_length (ra0));
1779 if (SCM_ARRAYP (ra1))
1780 {
1781 i1 = SCM_ARRAY_BASE (ra1);
1782 inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1783 ra1 = SCM_ARRAY_V (ra1);
1784 }
1785 switch (SCM_TYP7 (ra0))
1786 {
1787 case scm_tc7_vector:
1788 case scm_tc7_wvect:
1789 default:
1790 for (; n--; i0 += inc0, i1 += inc1)
1791 {
1792 if (scm_is_false (as_equal))
1793 {
1794 if (scm_is_false (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
1795 return 0;
1796 }
1797 else if (scm_is_false (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
1798 return 0;
1799 }
1800 return 1;
1801 case scm_tc7_string:
1802 {
1803 const char *v0 = scm_i_string_chars (ra0) + i0;
1804 const char *v1 = scm_i_string_chars (ra1) + i1;
1805 for (; n--; v0 += inc0, v1 += inc1)
1806 if (*v0 != *v1)
1807 return 0;
1808 return 1;
1809 }
1810 case scm_tc7_byvect:
1811 {
1812 char *v0 = ((char *) SCM_UVECTOR_BASE (ra0)) + i0;
1813 char *v1 = ((char *) SCM_UVECTOR_BASE (ra1)) + i1;
1814 for (; n--; v0 += inc0, v1 += inc1)
1815 if (*v0 != *v1)
1816 return 0;
1817 return 1;
1818 }
1819 case scm_tc7_bvect:
1820 for (; n--; i0 += inc0, i1 += inc1)
1821 if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1))
1822 return 0;
1823 return 1;
1824 case scm_tc7_uvect:
1825 case scm_tc7_ivect:
1826 {
1827 long *v0 = (long *) SCM_VELTS (ra0) + i0;
1828 long *v1 = (long *) SCM_VELTS (ra1) + i1;
1829 for (; n--; v0 += inc0, v1 += inc1)
1830 if (*v0 != *v1)
1831 return 0;
1832 return 1;
1833 }
1834 case scm_tc7_svect:
1835 {
1836 short *v0 = (short *) SCM_VELTS (ra0) + i0;
1837 short *v1 = (short *) SCM_VELTS (ra1) + i1;
1838 for (; n--; v0 += inc0, v1 += inc1)
1839 if (*v0 != *v1)
1840 return 0;
1841 return 1;
1842 }
1843 #if SCM_SIZEOF_LONG_LONG != 0
1844 case scm_tc7_llvect:
1845 {
1846 long long *v0 = (long long *) SCM_VELTS (ra0) + i0;
1847 long long *v1 = (long long *) SCM_VELTS (ra1) + i1;
1848 for (; n--; v0 += inc0, v1 += inc1)
1849 if (*v0 != *v1)
1850 return 0;
1851 return 1;
1852 }
1853 #endif
1854 case scm_tc7_fvect:
1855 {
1856 float *v0 = (float *) SCM_VELTS (ra0) + i0;
1857 float *v1 = (float *) SCM_VELTS (ra1) + i1;
1858 for (; n--; v0 += inc0, v1 += inc1)
1859 if (*v0 != *v1)
1860 return 0;
1861 return 1;
1862 }
1863 case scm_tc7_dvect:
1864 {
1865 double *v0 = (double *) SCM_VELTS (ra0) + i0;
1866 double *v1 = (double *) SCM_VELTS (ra1) + i1;
1867 for (; n--; v0 += inc0, v1 += inc1)
1868 if (*v0 != *v1)
1869 return 0;
1870 return 1;
1871 }
1872 case scm_tc7_cvect:
1873 {
1874 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
1875 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
1876 for (; n--; v0 += inc0, v1 += inc1)
1877 {
1878 if ((*v0)[0] != (*v1)[0])
1879 return 0;
1880 if ((*v0)[1] != (*v1)[1])
1881 return 0;
1882 }
1883 return 1;
1884 }
1885 }
1886 }
1887
1888
1889
1890 static int
1891 raeql (SCM ra0, SCM as_equal, SCM ra1)
1892 {
1893 SCM v0 = ra0, v1 = ra1;
1894 scm_t_array_dim dim0, dim1;
1895 scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
1896 unsigned long bas0 = 0, bas1 = 0;
1897 int k, unroll = 1, vlen = 1, ndim = 1;
1898 if (SCM_ARRAYP (ra0))
1899 {
1900 ndim = SCM_ARRAY_NDIM (ra0);
1901 s0 = SCM_ARRAY_DIMS (ra0);
1902 bas0 = SCM_ARRAY_BASE (ra0);
1903 v0 = SCM_ARRAY_V (ra0);
1904 }
1905 else
1906 {
1907 s0->inc = 1;
1908 s0->lbnd = 0;
1909 s0->ubnd = scm_to_long (scm_uniform_vector_length (v0)) - 1;
1910 unroll = 0;
1911 }
1912 if (SCM_ARRAYP (ra1))
1913 {
1914 if (ndim != SCM_ARRAY_NDIM (ra1))
1915 return 0;
1916 s1 = SCM_ARRAY_DIMS (ra1);
1917 bas1 = SCM_ARRAY_BASE (ra1);
1918 v1 = SCM_ARRAY_V (ra1);
1919 }
1920 else
1921 {
1922 /*
1923 Huh ? Schizophrenic return type. --hwn
1924 */
1925 if (1 != ndim)
1926 return 0;
1927 s1->inc = 1;
1928 s1->lbnd = 0;
1929 s1->ubnd = scm_to_long (scm_uniform_vector_length (v1)) - 1;
1930 unroll = 0;
1931 }
1932 if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
1933 return 0;
1934 for (k = ndim; k--;)
1935 {
1936 if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
1937 return 0;
1938 if (unroll)
1939 {
1940 unroll = (s0[k].inc == s1[k].inc);
1941 vlen *= s0[k].ubnd - s1[k].lbnd + 1;
1942 }
1943 }
1944 if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
1945 return 1;
1946 return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
1947 }
1948
1949
1950 SCM
1951 scm_raequal (SCM ra0, SCM ra1)
1952 {
1953 return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
1954 }
1955
1956 #if 0
1957 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1958 SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
1959 (SCM ra0, SCM ra1),
1960 "Return @code{#t} iff all arguments are arrays with the same\n"
1961 "shape, the same type, and have corresponding elements which are\n"
1962 "either @code{equal?} or @code{array-equal?}. This function\n"
1963 "differs from @code{equal?} in that a one dimensional shared\n"
1964 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1965 "vector or uniform vector.")
1966 #define FUNC_NAME s_scm_array_equal_p
1967 {
1968 }
1969 #undef FUNC_NAME
1970 #endif
1971
1972 static char s_array_equal_p[] = "array-equal?";
1973
1974
1975 SCM
1976 scm_array_equal_p (SCM ra0, SCM ra1)
1977 {
1978 if (SCM_IMP (ra0) || SCM_IMP (ra1))
1979 callequal:return scm_equal_p (ra0, ra1);
1980 switch (SCM_TYP7(ra0))
1981 {
1982 default:
1983 goto callequal;
1984 case scm_tc7_bvect:
1985 case scm_tc7_string:
1986 case scm_tc7_byvect:
1987 case scm_tc7_uvect:
1988 case scm_tc7_ivect:
1989 case scm_tc7_fvect:
1990 case scm_tc7_dvect:
1991 case scm_tc7_cvect:
1992 case scm_tc7_vector:
1993 case scm_tc7_wvect:
1994 break;
1995 case scm_tc7_smob:
1996 if (!SCM_ARRAYP (ra0))
1997 goto callequal;
1998 }
1999 switch (SCM_TYP7 (ra1))
2000 {
2001 default:
2002 goto callequal;
2003 case scm_tc7_bvect:
2004 case scm_tc7_string:
2005 case scm_tc7_byvect:
2006 case scm_tc7_uvect:
2007 case scm_tc7_ivect:
2008 case scm_tc7_fvect:
2009 case scm_tc7_dvect:
2010 case scm_tc7_cvect:
2011 case scm_tc7_vector:
2012 case scm_tc7_wvect:
2013 break;
2014 case scm_tc7_smob:
2015 if (!SCM_ARRAYP (ra1))
2016 goto callequal;
2017 }
2018 return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
2019 }
2020
2021
2022 static void
2023 init_raprocs (ra_iproc *subra)
2024 {
2025 for (; subra->name; subra++)
2026 {
2027 SCM sym = scm_from_locale_symbol (subra->name);
2028 SCM var =
2029 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
2030 if (var != SCM_BOOL_F)
2031 subra->sproc = SCM_VARIABLE_REF (var);
2032 else
2033 subra->sproc = SCM_BOOL_F;
2034 }
2035 }
2036
2037
2038 void
2039 scm_init_ramap ()
2040 {
2041 init_raprocs (ra_rpsubrs);
2042 init_raprocs (ra_asubrs);
2043 scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
2044 scm_smobs[SCM_TC2SMOBNUM (scm_tc16_array)].equalp = scm_raequal;
2045 #include "libguile/ramap.x"
2046 scm_add_feature (s_scm_array_for_each);
2047 }
2048
2049 /*
2050 Local Variables:
2051 c-file-style: "gnu"
2052 End:
2053 */
Unnamed repository; edit this file 'description' to name the repository.