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