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