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