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