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