HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
* *.c: Finish replacing K&R style prototypes with ANSI C
[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
186 (ras)
187 {
188 ra1 = SCM_CAR (ras);
189 if (SCM_IMP (ra1))
190 return 0;
191 switch SCM_TYP7
192 (ra1)
193 {
194 default:
195 return 0;
196 case scm_tc7_vector:
197 case scm_tc7_wvect:
198 case scm_tc7_string:
199 case scm_tc7_byvect:
200 case scm_tc7_bvect:
201 case scm_tc7_uvect:
202 case scm_tc7_ivect:
203 case scm_tc7_svect:
204 #ifdef HAVE_LONG_LONGS
205 case scm_tc7_llvect:
206 #endif
207 case scm_tc7_fvect:
208 case scm_tc7_dvect:
209 case scm_tc7_cvect:
210 if (1 != ndim)
211 return 0;
212 switch (exact)
213 {
214 case 4:
215 if (0 != bas0)
216 exact = 3;
217 case 3:
218 if (1 != s0->inc)
219 exact = 2;
220 case 2:
221 if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
222 break;
223 exact = 1;
224 case 1:
225 if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
226 return 0;
227 }
228 break;
229 case scm_tc7_smob:
230 if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
231 return 0;
232 s1 = SCM_ARRAY_DIMS (ra1);
233 if (bas0 != SCM_ARRAY_BASE (ra1))
234 exact = 3;
235 for (i = 0; i < ndim; i++)
236 switch (exact)
237 {
238 case 4:
239 case 3:
240 if (s0[i].inc != s1[i].inc)
241 exact = 2;
242 case 2:
243 if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
244 break;
245 exact = 1;
246 default:
247 if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
248 return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
249 }
250 break;
251 }
252 ras = SCM_CDR (ras);
253 }
254 return exact;
255 }
256
257 /* array mapper: apply cproc to each dimension of the given arrays?.
258 int (*cproc) (); procedure to call on unrolled arrays?
259 cproc (dest, source list) or
260 cproc (dest, data, source list).
261 SCM data; data to give to cproc or unbound.
262 SCM ra0; destination array.
263 SCM lra; list of source arrays.
264 const char *what; caller, for error reporting. */
265 int
266 scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
267 {
268 SCM inds, z;
269 SCM vra0, ra1, vra1;
270 SCM lvra, *plvra;
271 long *vinds;
272 int k, kmax;
273 switch (scm_ra_matchp (ra0, lra))
274 {
275 default:
276 case 0:
277 scm_wta (ra0, "array shape mismatch", what);
278 case 2:
279 case 3:
280 case 4: /* Try unrolling arrays */
281 kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0);
282 if (kmax < 0)
283 goto gencase;
284 vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
285 if (SCM_IMP (vra0)) goto gencase;
286 if (!SCM_ARRAYP (vra0))
287 {
288 vra1 = scm_make_ra (1);
289 SCM_ARRAY_BASE (vra1) = 0;
290 SCM_ARRAY_DIMS (vra1)->lbnd = 0;
291 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1;
292 SCM_ARRAY_DIMS (vra1)->inc = 1;
293 SCM_ARRAY_V (vra1) = vra0;
294 vra0 = vra1;
295 }
296 lvra = SCM_EOL;
297 plvra = &lvra;
298 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
299 {
300 ra1 = SCM_CAR (z);
301 vra1 = scm_make_ra (1);
302 SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
303 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
304 if (!SCM_ARRAYP (ra1))
305 {
306 SCM_ARRAY_BASE (vra1) = 0;
307 SCM_ARRAY_DIMS (vra1)->inc = 1;
308 SCM_ARRAY_V (vra1) = ra1;
309 }
310 else if (!SCM_ARRAY_CONTP (ra1))
311 goto gencase;
312 else
313 {
314 SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1);
315 SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
316 SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
317 }
318 *plvra = scm_cons (vra1, SCM_EOL);
319 plvra = SCM_CDRLOC (*plvra);
320 }
321 return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
322 case 1:
323 gencase: /* Have to loop over all dimensions. */
324 vra0 = scm_make_ra (1);
325 if (SCM_ARRAYP (ra0))
326 {
327 kmax = SCM_ARRAY_NDIM (ra0) - 1;
328 if (kmax < 0)
329 {
330 SCM_ARRAY_DIMS (vra0)->lbnd = 0;
331 SCM_ARRAY_DIMS (vra0)->ubnd = 0;
332 SCM_ARRAY_DIMS (vra0)->inc = 1;
333 }
334 else
335 {
336 SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
337 SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
338 SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
339 }
340 SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
341 SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
342 }
343 else
344 {
345 kmax = 0;
346 SCM_ARRAY_DIMS (vra0)->lbnd = 0;
347 SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
348 SCM_ARRAY_DIMS (vra0)->inc = 1;
349 SCM_ARRAY_BASE (vra0) = 0;
350 SCM_ARRAY_V (vra0) = ra0;
351 ra0 = vra0;
352 }
353 lvra = SCM_EOL;
354 plvra = &lvra;
355 for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
356 {
357 ra1 = SCM_CAR (z);
358 vra1 = scm_make_ra (1);
359 SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
360 SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
361 if (SCM_ARRAYP (ra1))
362 {
363 if (kmax >= 0)
364 SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
365 SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
366 }
367 else
368 {
369 SCM_ARRAY_DIMS (vra1)->inc = 1;
370 SCM_ARRAY_V (vra1) = ra1;
371 }
372 *plvra = scm_cons (vra1, SCM_EOL);
373 plvra = SCM_CDRLOC (*plvra);
374 }
375 inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
376 vinds = (long *) SCM_VELTS (inds);
377 for (k = 0; k <= kmax; k++)
378 vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
379 k = kmax;
380 do
381 {
382 if (k == kmax)
383 {
384 SCM y = lra;
385 SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
386 for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
387 SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
388 if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
389 return 0;
390 k--;
391 continue;
392 }
393 if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
394 {
395 vinds[k]++;
396 k++;
397 continue;
398 }
399 vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
400 k--;
401 }
402 while (k >= 0);
403 return 1;
404 }
405 }
406
407
408 GUILE_PROC(scm_array_fill_x, "array-fill!", 2, 0, 0,
409 (SCM ra, SCM fill),
410 "")
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_NIMP (fill) && 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_NIMP (fill) && 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_NIMP (fill) && 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 #undef FUNC_NAME
772
773
774 /* This name is obsolete. Will go away in release 1.5. */
775 SCM_REGISTER_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
776 SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
777
778
779 GUILE_PROC(scm_array_copy_x, "array-copy!", 2, 0, 0,
780 (SCM src, SCM dst),
781 "")
782 #define FUNC_NAME s_scm_array_copy_x
783 {
784 SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL));
785 return SCM_UNSPECIFIED;
786 }
787 #undef FUNC_NAME
788
789 /* Functions callable by ARRAY-MAP! */
790
791
792 int
793 scm_ra_eqp (SCM ra0, SCM ras)
794 {
795 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
796 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
797 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
798 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
799 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
800 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
801 ra0 = SCM_ARRAY_V (ra0);
802 ra1 = SCM_ARRAY_V (ra1);
803 ra2 = SCM_ARRAY_V (ra2);
804 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
805 {
806 default:
807 {
808 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
809 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
810 if (BVE_REF (ra0, i0))
811 if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
812 BVE_CLR (ra0, i0);
813 break;
814 }
815 case scm_tc7_uvect:
816 case scm_tc7_ivect:
817 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
818 if (BVE_REF (ra0, i0))
819 if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
820 BVE_CLR (ra0, i0);
821 break;
822 #ifdef SCM_FLOATS
823 #ifdef SCM_SINGLES
824 case scm_tc7_fvect:
825 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
826 if (BVE_REF (ra0, i0))
827 if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
828 BVE_CLR (ra0, i0);
829 break;
830 #endif /*SCM_SINGLES*/
831 case scm_tc7_dvect:
832 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
833 if (BVE_REF (ra0, i0))
834 if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
835 BVE_CLR (ra0, i0);
836 break;
837 case scm_tc7_cvect:
838 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
839 if (BVE_REF (ra0, i0))
840 if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
841 ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
842 BVE_CLR (ra0, i0);
843 break;
844 #endif /*SCM_FLOATS*/
845 }
846 return 1;
847 }
848
849 /* opt 0 means <, nonzero means >= */
850
851 static int
852 ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
853 {
854 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
855 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
856 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
857 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
858 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
859 ra0 = SCM_ARRAY_V (ra0);
860 ra1 = SCM_ARRAY_V (ra1);
861 ra2 = SCM_ARRAY_V (ra2);
862 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
863 {
864 default:
865 {
866 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
867 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
868 if (BVE_REF (ra0, i0))
869 if (opt ?
870 SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
871 SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
872 BVE_CLR (ra0, i0);
873 break;
874 }
875 case scm_tc7_uvect:
876 case scm_tc7_ivect:
877 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
878 {
879 if (BVE_REF (ra0, i0))
880 if (opt ?
881 SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
882 SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
883 BVE_CLR (ra0, i0);
884 }
885 break;
886 #ifdef SCM_FLOATS
887 #ifdef SCM_SINGLES
888 case scm_tc7_fvect:
889 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
890 if (BVE_REF(ra0, i0))
891 if (opt ?
892 ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
893 ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
894 BVE_CLR (ra0, i0);
895 break;
896 #endif /*SCM_SINGLES*/
897 case scm_tc7_dvect:
898 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
899 if (BVE_REF (ra0, i0))
900 if (opt ?
901 ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
902 ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
903 BVE_CLR (ra0, i0);
904 break;
905 #endif /*SCM_FLOATS*/
906 }
907 return 1;
908 }
909
910
911
912 int
913 scm_ra_lessp (SCM ra0, SCM ras)
914 {
915 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
916 }
917
918
919 int
920 scm_ra_leqp (SCM ra0, SCM ras)
921 {
922 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
923 }
924
925
926 int
927 scm_ra_grp (SCM ra0, SCM ras)
928 {
929 return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
930 }
931
932
933 int
934 scm_ra_greqp (SCM ra0, SCM ras)
935 {
936 return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
937 }
938
939
940 int
941 scm_ra_sum (SCM ra0, SCM ras)
942 {
943 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
944 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
945 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
946 ra0 = SCM_ARRAY_V (ra0);
947 if (SCM_NNULLP(ras))
948 {
949 SCM ra1 = SCM_CAR (ras);
950 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
951 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
952 ra1 = SCM_ARRAY_V (ra1);
953 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
954 {
955 default:
956 {
957 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
958 for (; n-- > 0; i0 += inc0, i1 += inc1)
959 scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
960 SCM_MAKINUM (i0));
961 break;
962 }
963 case scm_tc7_uvect:
964 case scm_tc7_ivect:
965 {
966 long *v0 = SCM_VELTS (ra0);
967 long *v1 = SCM_VELTS (ra1);
968 IVDEP (ra0 != ra1,
969 for (; n-- > 0; i0 += inc0, i1 += inc1)
970 v0[i0] += v1[i1];)
971 break;
972 }
973 #ifdef SCM_FLOATS
974 #ifdef SCM_SINGLES
975 case scm_tc7_fvect:
976 {
977 float *v0 = (float *) SCM_VELTS (ra0);
978 float *v1 = (float *) SCM_VELTS (ra1);
979 IVDEP (ra0 != ra1,
980 for (; n-- > 0; i0 += inc0, i1 += inc1)
981 v0[i0] += v1[i1];)
982 break;
983 }
984 #endif /* SCM_SINGLES */
985 case scm_tc7_dvect:
986 {
987 double *v0 = (double *) SCM_VELTS (ra0);
988 double *v1 = (double *) SCM_VELTS (ra1);
989 IVDEP (ra0 != ra1,
990 for (; n-- > 0; i0 += inc0, i1 += inc1)
991 v0[i0] += v1[i1];)
992 break;
993 }
994 case scm_tc7_cvect:
995 {
996 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
997 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
998 IVDEP (ra0 != ra1,
999 for (; n-- > 0; i0 += inc0, i1 += inc1)
1000 {
1001 v0[i0][0] += v1[i1][0];
1002 v0[i0][1] += v1[i1][1];
1003 }
1004 );
1005 break;
1006 }
1007 #endif /* SCM_FLOATS */
1008 }
1009 }
1010 return 1;
1011 }
1012
1013
1014
1015 int
1016 scm_ra_difference (SCM ra0, SCM ras)
1017 {
1018 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1019 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1020 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1021 ra0 = SCM_ARRAY_V (ra0);
1022 if (SCM_NULLP (ras))
1023 {
1024 switch (SCM_TYP7 (ra0))
1025 {
1026 default:
1027 {
1028 SCM e0 = SCM_UNDEFINED;
1029 for (; n-- > 0; i0 += inc0)
1030 scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1031 break;
1032 }
1033 #ifdef SCM_FLOATS
1034 #ifdef SCM_SINGLES
1035 case scm_tc7_fvect:
1036 {
1037 float *v0 = (float *) SCM_VELTS (ra0);
1038 for (; n-- > 0; i0 += inc0)
1039 v0[i0] = -v0[i0];
1040 break;
1041 }
1042 #endif /* SCM_SINGLES */
1043 case scm_tc7_dvect:
1044 {
1045 double *v0 = (double *) SCM_VELTS (ra0);
1046 for (; n-- > 0; i0 += inc0)
1047 v0[i0] = -v0[i0];
1048 break;
1049 }
1050 case scm_tc7_cvect:
1051 {
1052 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1053 for (; n-- > 0; i0 += inc0)
1054 {
1055 v0[i0][0] = -v0[i0][0];
1056 v0[i0][1] = -v0[i0][1];
1057 }
1058 break;
1059 }
1060 #endif /* SCM_FLOATS */
1061 }
1062 }
1063 else
1064 {
1065 SCM ra1 = SCM_CAR (ras);
1066 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1067 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1068 ra1 = SCM_ARRAY_V (ra1);
1069 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1070 {
1071 default:
1072 {
1073 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1074 for (; n-- > 0; i0 += inc0, i1 += inc1)
1075 scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1076 break;
1077 }
1078 #ifdef SCM_FLOATS
1079 #ifdef SCM_SINGLES
1080 case scm_tc7_fvect:
1081 {
1082 float *v0 = (float *) SCM_VELTS (ra0);
1083 float *v1 = (float *) SCM_VELTS (ra1);
1084 IVDEP (ra0 != ra1,
1085 for (; n-- > 0; i0 += inc0, i1 += inc1)
1086 v0[i0] -= v1[i1];)
1087 break;
1088 }
1089 #endif /* SCM_SINGLES */
1090 case scm_tc7_dvect:
1091 {
1092 double *v0 = (double *) SCM_VELTS (ra0);
1093 double *v1 = (double *) SCM_VELTS (ra1);
1094 IVDEP (ra0 != ra1,
1095 for (; n-- > 0; i0 += inc0, i1 += inc1)
1096 v0[i0] -= v1[i1];)
1097 break;
1098 }
1099 case scm_tc7_cvect:
1100 {
1101 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1102 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1103 IVDEP (ra0 != ra1,
1104 for (; n-- > 0; i0 += inc0, i1 += inc1)
1105 {
1106 v0[i0][0] -= v1[i1][0];
1107 v0[i0][1] -= v1[i1][1];
1108 }
1109 )
1110 break;
1111 }
1112 #endif /* SCM_FLOATS */
1113 }
1114 }
1115 return 1;
1116 }
1117
1118
1119
1120 int
1121 scm_ra_product (SCM ra0, SCM ras)
1122 {
1123 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1124 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1125 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1126 ra0 = SCM_ARRAY_V (ra0);
1127 if (SCM_NNULLP (ras))
1128 {
1129 SCM ra1 = SCM_CAR (ras);
1130 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1131 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1132 ra1 = SCM_ARRAY_V (ra1);
1133 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1134 {
1135 default:
1136 {
1137 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1138 for (; n-- > 0; i0 += inc0, i1 += inc1)
1139 scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1140 SCM_MAKINUM (i0));
1141 break;
1142 }
1143 case scm_tc7_uvect:
1144 case scm_tc7_ivect:
1145 {
1146 long *v0 = SCM_VELTS (ra0);
1147 long *v1 = SCM_VELTS (ra1);
1148 IVDEP (ra0 != ra1,
1149 for (; n-- > 0; i0 += inc0, i1 += inc1)
1150 v0[i0] *= v1[i1];)
1151 break;
1152 }
1153 #ifdef SCM_FLOATS
1154 #ifdef SCM_SINGLES
1155 case scm_tc7_fvect:
1156 {
1157 float *v0 = (float *) SCM_VELTS (ra0);
1158 float *v1 = (float *) SCM_VELTS (ra1);
1159 IVDEP (ra0 != ra1,
1160 for (; n-- > 0; i0 += inc0, i1 += inc1)
1161 v0[i0] *= v1[i1];)
1162 break;
1163 }
1164 #endif /* SCM_SINGLES */
1165 case scm_tc7_dvect:
1166 {
1167 double *v0 = (double *) SCM_VELTS (ra0);
1168 double *v1 = (double *) SCM_VELTS (ra1);
1169 IVDEP (ra0 != ra1,
1170 for (; n-- > 0; i0 += inc0, i1 += inc1)
1171 v0[i0] *= v1[i1];)
1172 break;
1173 }
1174 case scm_tc7_cvect:
1175 {
1176 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1177 register double r;
1178 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1179 IVDEP (ra0 != ra1,
1180 for (; n-- > 0; i0 += inc0, i1 += inc1)
1181 {
1182 r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
1183 v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
1184 v0[i0][0] = r;
1185 }
1186 );
1187 break;
1188 }
1189 #endif /* SCM_FLOATS */
1190 }
1191 }
1192 return 1;
1193 }
1194
1195
1196 int
1197 scm_ra_divide (SCM ra0, SCM ras)
1198 {
1199 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1200 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1201 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1202 ra0 = SCM_ARRAY_V (ra0);
1203 if (SCM_NULLP (ras))
1204 {
1205 switch (SCM_TYP7 (ra0))
1206 {
1207 default:
1208 {
1209 SCM e0 = SCM_UNDEFINED;
1210 for (; n-- > 0; i0 += inc0)
1211 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1212 break;
1213 }
1214 #ifdef SCM_FLOATS
1215 #ifdef SCM_SINGLES
1216 case scm_tc7_fvect:
1217 {
1218 float *v0 = (float *) SCM_VELTS (ra0);
1219 for (; n-- > 0; i0 += inc0)
1220 v0[i0] = 1.0 / v0[i0];
1221 break;
1222 }
1223 #endif /* SCM_SINGLES */
1224 case scm_tc7_dvect:
1225 {
1226 double *v0 = (double *) SCM_VELTS (ra0);
1227 for (; n-- > 0; i0 += inc0)
1228 v0[i0] = 1.0 / v0[i0];
1229 break;
1230 }
1231 case scm_tc7_cvect:
1232 {
1233 register double d;
1234 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1235 for (; n-- > 0; i0 += inc0)
1236 {
1237 d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
1238 v0[i0][0] /= d;
1239 v0[i0][1] /= -d;
1240 }
1241 break;
1242 }
1243 #endif /* SCM_FLOATS */
1244 }
1245 }
1246 else
1247 {
1248 SCM ra1 = SCM_CAR (ras);
1249 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1250 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1251 ra1 = SCM_ARRAY_V (ra1);
1252 switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
1253 {
1254 default:
1255 {
1256 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1257 for (; n-- > 0; i0 += inc0, i1 += inc1)
1258 scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1259 break;
1260 }
1261 #ifdef SCM_FLOATS
1262 #ifdef SCM_SINGLES
1263 case scm_tc7_fvect:
1264 {
1265 float *v0 = (float *) SCM_VELTS (ra0);
1266 float *v1 = (float *) SCM_VELTS (ra1);
1267 IVDEP (ra0 != ra1,
1268 for (; n-- > 0; i0 += inc0, i1 += inc1)
1269 v0[i0] /= v1[i1];)
1270 break;
1271 }
1272 #endif /* SCM_SINGLES */
1273 case scm_tc7_dvect:
1274 {
1275 double *v0 = (double *) SCM_VELTS (ra0);
1276 double *v1 = (double *) SCM_VELTS (ra1);
1277 IVDEP (ra0 != ra1,
1278 for (; n-- > 0; i0 += inc0, i1 += inc1)
1279 v0[i0] /= v1[i1];)
1280 break;
1281 }
1282 case scm_tc7_cvect:
1283 {
1284 register double d, r;
1285 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
1286 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
1287 IVDEP (ra0 != ra1,
1288 for (; n-- > 0; i0 += inc0, i1 += inc1)
1289 {
1290 d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
1291 r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
1292 v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
1293 v0[i0][0] = r;
1294 }
1295 )
1296 break;
1297 }
1298 #endif /* SCM_FLOATS */
1299 }
1300 }
1301 return 1;
1302 }
1303
1304
1305 int
1306 scm_array_identity (SCM dst, SCM src)
1307 {
1308 return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
1309 }
1310
1311
1312
1313 static int
1314 ramap (SCM ra0,SCM proc,SCM ras)
1315 {
1316 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1317 long inc = SCM_ARRAY_DIMS (ra0)->inc;
1318 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1319 long base = SCM_ARRAY_BASE (ra0) - i * inc;
1320 ra0 = SCM_ARRAY_V (ra0);
1321 if (SCM_NULLP (ras))
1322 for (; i <= n; i++)
1323 scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
1324 else
1325 {
1326 SCM ra1 = SCM_CAR (ras);
1327 SCM args, *ve = &ras;
1328 scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
1329 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1330 ra1 = SCM_ARRAY_V (ra1);
1331 ras = SCM_CDR (ras);
1332 if (SCM_NULLP(ras))
1333 ras = scm_nullvect;
1334 else
1335 {
1336 ras = scm_vector (ras);
1337 ve = SCM_VELTS (ras);
1338 }
1339 for (; i <= n; i++, i1 += inc1)
1340 {
1341 args = SCM_EOL;
1342 for (k = SCM_LENGTH (ras); k--;)
1343 args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
1344 args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1345 scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base));
1346 }
1347 }
1348 return 1;
1349 }
1350
1351
1352 static int
1353 ramap_cxr (SCM ra0,SCM proc,SCM ras)
1354 {
1355 SCM ra1 = SCM_CAR (ras);
1356 SCM e1 = SCM_UNDEFINED;
1357 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1358 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1359 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1;
1360 ra0 = SCM_ARRAY_V (ra0);
1361 ra1 = SCM_ARRAY_V (ra1);
1362 switch (SCM_TYP7 (ra0))
1363 {
1364 default:
1365 gencase:
1366 for (; n-- > 0; i0 += inc0, i1 += inc1)
1367 scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
1368 break;
1369 #ifdef SCM_FLOATS
1370 #ifdef SCM_SINGLES
1371 case scm_tc7_fvect:
1372 {
1373 float *dst = (float *) SCM_VELTS (ra0);
1374 switch (SCM_TYP7 (ra1))
1375 {
1376 default:
1377 goto gencase;
1378 case scm_tc7_fvect:
1379 for (; n-- > 0; i0 += inc0, i1 += inc1)
1380 dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
1381 break;
1382 case scm_tc7_uvect:
1383 case scm_tc7_ivect:
1384 for (; n-- > 0; i0 += inc0, i1 += inc1)
1385 dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
1386 break;
1387 }
1388 break;
1389 }
1390 #endif /* SCM_SINGLES */
1391 case scm_tc7_dvect:
1392 {
1393 double *dst = (double *) SCM_VELTS (ra0);
1394 switch (SCM_TYP7 (ra1))
1395 {
1396 default:
1397 goto gencase;
1398 case scm_tc7_dvect:
1399 for (; n-- > 0; i0 += inc0, i1 += inc1)
1400 dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
1401 break;
1402 case scm_tc7_uvect:
1403 case scm_tc7_ivect:
1404 for (; n-- > 0; i0 += inc0, i1 += inc1)
1405 dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
1406 break;
1407 }
1408 break;
1409 }
1410 #endif /* SCM_FLOATS */
1411 }
1412 return 1;
1413 }
1414
1415
1416
1417 static int
1418 ramap_rp (SCM ra0,SCM proc,SCM ras)
1419 {
1420 SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
1421 SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
1422 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1423 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
1424 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1425 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1426 long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
1427 ra0 = SCM_ARRAY_V (ra0);
1428 ra1 = SCM_ARRAY_V (ra1);
1429 ra2 = SCM_ARRAY_V (ra2);
1430 switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
1431 {
1432 default:
1433 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1434 if (BVE_REF (ra0, i0))
1435 if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
1436 BVE_CLR (ra0, i0);
1437 break;
1438 case scm_tc7_uvect:
1439 case scm_tc7_ivect:
1440 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1441 if (BVE_REF (ra0, i0))
1442 {
1443 if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
1444 SCM_MAKINUM (SCM_VELTS (ra2)[i2]))))
1445 BVE_CLR (ra0, i0);
1446 }
1447 break;
1448 #ifdef SCM_FLOATS
1449 #ifdef SCM_SINGLES
1450 case scm_tc7_fvect:
1451 {
1452 SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
1453 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1454 if (BVE_REF (ra0, i0))
1455 {
1456 SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
1457 SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
1458 if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
1459 BVE_CLR (ra0, i0);
1460 }
1461 break;
1462 }
1463 #endif /*SCM_SINGLES*/
1464 case scm_tc7_dvect:
1465 {
1466 SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
1467 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1468 if (BVE_REF (ra0, i0))
1469 {
1470 SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
1471 SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
1472 if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
1473 BVE_CLR (ra0, i0);
1474 }
1475 break;
1476 }
1477 case scm_tc7_cvect:
1478 {
1479 SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
1480 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1481 if (BVE_REF (ra0, i0))
1482 {
1483 SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
1484 SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
1485 SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
1486 SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
1487 if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
1488 BVE_CLR (ra0, i0);
1489 }
1490 break;
1491 }
1492 #endif /*SCM_FLOATS*/
1493 }
1494 return 1;
1495 }
1496
1497
1498
1499 static int
1500 ramap_1 (SCM ra0,SCM proc,SCM ras)
1501 {
1502 SCM ra1 = SCM_CAR (ras);
1503 SCM e1 = SCM_UNDEFINED;
1504 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1505 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1506 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1507 ra0 = SCM_ARRAY_V (ra0);
1508 ra1 = SCM_ARRAY_V (ra1);
1509 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
1510 for (; n-- > 0; i0 += inc0, i1 += inc1)
1511 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0));
1512 else
1513 for (; n-- > 0; i0 += inc0, i1 += inc1)
1514 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
1515 return 1;
1516 }
1517
1518
1519
1520 static int
1521 ramap_2o (SCM ra0,SCM proc,SCM ras)
1522 {
1523 SCM ra1 = SCM_CAR (ras);
1524 SCM e1 = SCM_UNDEFINED;
1525 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1526 scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
1527 long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1528 ra0 = SCM_ARRAY_V (ra0);
1529 ra1 = SCM_ARRAY_V (ra1);
1530 ras = SCM_CDR (ras);
1531 if (SCM_NULLP (ras))
1532 {
1533 if (scm_tc7_vector == SCM_TYP7 (ra0)
1534 || scm_tc7_wvect == SCM_TYP7 (ra0))
1535
1536 for (; n-- > 0; i0 += inc0, i1 += inc1)
1537 scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
1538 SCM_MAKINUM (i0));
1539 else
1540 for (; n-- > 0; i0 += inc0, i1 += inc1)
1541 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
1542 SCM_MAKINUM (i0));
1543 }
1544 else
1545 {
1546 SCM ra2 = SCM_CAR (ras);
1547 SCM e2 = SCM_UNDEFINED;
1548 scm_sizet i2 = SCM_ARRAY_BASE (ra2);
1549 long inc2 = SCM_ARRAY_DIMS (ra2)->inc;
1550 ra2 = SCM_ARRAY_V (ra2);
1551 if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
1552 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1553 scm_array_set_x (ra0,
1554 SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
1555 SCM_MAKINUM (i0));
1556 else
1557 for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
1558 scm_array_set_x (ra0,
1559 SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
1560 SCM_MAKINUM (i0));
1561 }
1562 return 1;
1563 }
1564
1565
1566
1567 static int
1568 ramap_a (SCM ra0,SCM proc,SCM ras)
1569 {
1570 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1571 long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1572 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1573 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1574 ra0 = SCM_ARRAY_V (ra0);
1575 if (SCM_NULLP (ras))
1576 for (; n-- > 0; i0 += inc0)
1577 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
1578 else
1579 {
1580 SCM ra1 = SCM_CAR (ras);
1581 scm_sizet i1 = SCM_ARRAY_BASE (ra1);
1582 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1583 ra1 = SCM_ARRAY_V (ra1);
1584 for (; n-- > 0; i0 += inc0, i1 += inc1)
1585 scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
1586 SCM_MAKINUM (i0));
1587 }
1588 return 1;
1589 }
1590
1591 /* This name is obsolete. Will go away in release 1.5. */
1592 SCM_REGISTER_PROC(s_serial_array_map_x, "serial-array-map!", 2, 0, 1, scm_array_map_x);
1593 SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
1594
1595
1596 GUILE_PROC(scm_array_map_x, "array-map!", 2, 0, 1,
1597 (SCM ra0, SCM proc, SCM lra),
1598 "")
1599 #define FUNC_NAME s_scm_array_map_x
1600 {
1601 SCM_VALIDATE_PROC(2,proc);
1602 switch (SCM_TYP7 (proc))
1603 {
1604 default:
1605 gencase:
1606 SCM_RAMAPC (ramap, proc, ra0, lra);
1607 return SCM_UNSPECIFIED;
1608 case scm_tc7_subr_1:
1609 SCM_RAMAPC (ramap_1, proc, ra0, lra);
1610 return SCM_UNSPECIFIED;
1611 case scm_tc7_subr_2:
1612 case scm_tc7_subr_2o:
1613 SCM_RAMAPC (ramap_2o, proc, ra0, lra);
1614 return SCM_UNSPECIFIED;
1615 case scm_tc7_cxr:
1616 if (!SCM_SUBRF (proc))
1617 goto gencase;
1618 SCM_RAMAPC (ramap_cxr, proc, ra0, lra);
1619 return SCM_UNSPECIFIED;
1620 case scm_tc7_rpsubr:
1621 {
1622 ra_iproc *p;
1623 if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
1624 goto gencase;
1625 scm_array_fill_x (ra0, SCM_BOOL_T);
1626 for (p = ra_rpsubrs; p->name; p++)
1627 if (proc == p->sproc)
1628 {
1629 while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
1630 {
1631 SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
1632 lra = SCM_CDR (lra);
1633 }
1634 return SCM_UNSPECIFIED;
1635 }
1636 while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
1637 {
1638 SCM_RAMAPC (ramap_rp, proc, ra0, lra);
1639 lra = SCM_CDR (lra);
1640 }
1641 return SCM_UNSPECIFIED;
1642 }
1643 case scm_tc7_asubr:
1644 if (SCM_NULLP (lra))
1645 {
1646 SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
1647 if (SCM_INUMP(fill))
1648 {
1649 prot = scm_array_prototype (ra0);
1650 if (SCM_NIMP (prot) && SCM_INEXP (prot))
1651 fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
1652 }
1653
1654 scm_array_fill_x (ra0, fill);
1655 }
1656 else
1657 {
1658 SCM tail, ra1 = SCM_CAR (lra);
1659 SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
1660 ra_iproc *p;
1661 /* Check to see if order might matter.
1662 This might be an argument for a separate
1663 SERIAL-ARRAY-MAP! */
1664 if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
1665 if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
1666 goto gencase;
1667 for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
1668 {
1669 ra1 = SCM_CAR (tail);
1670 if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
1671 goto gencase;
1672 }
1673 for (p = ra_asubrs; p->name; p++)
1674 if (proc == p->sproc)
1675 {
1676 if (ra0 != SCM_CAR (lra))
1677 SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL));
1678 lra = SCM_CDR (lra);
1679 while (1)
1680 {
1681 SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
1682 if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
1683 return SCM_UNSPECIFIED;
1684 lra = SCM_CDR (lra);
1685 }
1686 }
1687 SCM_RAMAPC (ramap_2o, proc, ra0, lra);
1688 lra = SCM_CDR (lra);
1689 if (SCM_NIMP (lra))
1690 for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
1691 SCM_RAMAPC (ramap_a, proc, ra0, lra);
1692 }
1693 return SCM_UNSPECIFIED;
1694 }
1695 }
1696 #undef FUNC_NAME
1697
1698
1699 static int
1700 rafe (SCM ra0,SCM proc,SCM ras)
1701 {
1702 long i = SCM_ARRAY_DIMS (ra0)->lbnd;
1703 scm_sizet i0 = SCM_ARRAY_BASE (ra0);
1704 long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1705 long n = SCM_ARRAY_DIMS (ra0)->ubnd;
1706 ra0 = SCM_ARRAY_V (ra0);
1707 if (SCM_NULLP (ras))
1708 for (; i <= n; i++, i0 += inc0)
1709 scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
1710 else
1711 {
1712 SCM ra1 = SCM_CAR (ras);
1713 SCM args, *ve = &ras;
1714 scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
1715 long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1716 ra1 = SCM_ARRAY_V (ra1);
1717 ras = SCM_CDR (ras);
1718 if (SCM_NULLP(ras))
1719 ras = scm_nullvect;
1720 else
1721 {
1722 ras = scm_vector (ras);
1723 ve = SCM_VELTS (ras);
1724 }
1725 for (; i <= n; i++, i0 += inc0, i1 += inc1)
1726 {
1727 args = SCM_EOL;
1728 for (k = SCM_LENGTH (ras); k--;)
1729 args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
1730 args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
1731 scm_apply (proc, args, SCM_EOL);
1732 }
1733 }
1734 return 1;
1735 }
1736
1737
1738 GUILE_PROC(scm_array_for_each, "array-for-each", 2, 0, 1,
1739 (SCM proc, SCM ra0, SCM lra),
1740 "")
1741 #define FUNC_NAME s_scm_array_for_each
1742 {
1743 SCM_VALIDATE_PROC(1,proc);
1744 SCM_RAMAPC (rafe, proc, ra0, lra);
1745 return SCM_UNSPECIFIED;
1746 }
1747 #undef FUNC_NAME
1748
1749 GUILE_PROC(scm_array_index_map_x, "array-index-map!", 2, 0, 0,
1750 (SCM ra, SCM proc),
1751 "")
1752 #define FUNC_NAME s_scm_array_index_map_x
1753 {
1754 scm_sizet i;
1755 SCM_VALIDATE_NIM (1,ra);
1756 SCM_VALIDATE_PROC(2,proc);
1757 switch (SCM_TYP7(ra))
1758 {
1759 default:
1760 badarg:SCM_WTA (1,ra);
1761 case scm_tc7_vector:
1762 case scm_tc7_wvect:
1763 {
1764 SCM *ve = SCM_VELTS (ra);
1765 for (i = 0; i < SCM_LENGTH (ra); i++)
1766 ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
1767 return SCM_UNSPECIFIED;
1768 }
1769 case scm_tc7_string:
1770 case scm_tc7_byvect:
1771 case scm_tc7_bvect:
1772 case scm_tc7_uvect:
1773 case scm_tc7_ivect:
1774 case scm_tc7_svect:
1775 #ifdef HAVE_LONG_LONGS
1776 case scm_tc7_llvect:
1777 #endif
1778 case scm_tc7_fvect:
1779 case scm_tc7_dvect:
1780 case scm_tc7_cvect:
1781 for (i = 0; i < SCM_LENGTH (ra); i++)
1782 scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull),
1783 SCM_MAKINUM (i));
1784 return SCM_UNSPECIFIED;
1785 case scm_tc7_smob:
1786 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
1787 {
1788 SCM args = SCM_EOL;
1789 SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L));
1790 long *vinds = SCM_VELTS (inds);
1791 int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
1792 if (kmax < 0)
1793 return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL),
1794 SCM_EOL);
1795 for (k = 0; k <= kmax; k++)
1796 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1797 k = kmax;
1798 do
1799 {
1800 if (k == kmax)
1801 {
1802 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
1803 i = cind (ra, inds);
1804 for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
1805 {
1806 for (j = kmax + 1, args = SCM_EOL; j--;)
1807 args = scm_cons (SCM_MAKINUM (vinds[j]), args);
1808 scm_array_set_x (SCM_ARRAY_V (ra),
1809 scm_apply (proc, args, SCM_EOL),
1810 SCM_MAKINUM (i));
1811 i += SCM_ARRAY_DIMS (ra)[k].inc;
1812 }
1813 k--;
1814 continue;
1815 }
1816 if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd)
1817 {
1818 vinds[k]++;
1819 k++;
1820 continue;
1821 }
1822 vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1;
1823 k--;
1824 }
1825 while (k >= 0);
1826 return SCM_UNSPECIFIED;
1827 }
1828 }
1829 }
1830 #undef FUNC_NAME
1831
1832
1833 static int
1834 raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
1835 {
1836 SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
1837 scm_sizet i0 = 0, i1 = 0;
1838 long inc0 = 1, inc1 = 1;
1839 scm_sizet n = SCM_LENGTH (ra0);
1840 ra1 = SCM_CAR (ra1);
1841 if (SCM_ARRAYP(ra0))
1842 {
1843 n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
1844 i0 = SCM_ARRAY_BASE (ra0);
1845 inc0 = SCM_ARRAY_DIMS (ra0)->inc;
1846 ra0 = SCM_ARRAY_V (ra0);
1847 }
1848 if (SCM_ARRAYP (ra1))
1849 {
1850 i1 = SCM_ARRAY_BASE (ra1);
1851 inc1 = SCM_ARRAY_DIMS (ra1)->inc;
1852 ra1 = SCM_ARRAY_V (ra1);
1853 }
1854 switch (SCM_TYP7 (ra0))
1855 {
1856 case scm_tc7_vector:
1857 case scm_tc7_wvect:
1858 default:
1859 for (; n--; i0 += inc0, i1 += inc1)
1860 {
1861 if (SCM_FALSEP (as_equal))
1862 {
1863 if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
1864 return 0;
1865 }
1866 else if (SCM_FALSEP (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
1867 return 0;
1868 }
1869 return 1;
1870 case scm_tc7_string:
1871 case scm_tc7_byvect:
1872 {
1873 char *v0 = SCM_CHARS (ra0) + i0;
1874 char *v1 = SCM_CHARS (ra1) + i1;
1875 for (; n--; v0 += inc0, v1 += inc1)
1876 if (*v0 != *v1)
1877 return 0;
1878 return 1;
1879 }
1880 case scm_tc7_bvect:
1881 for (; n--; i0 += inc0, i1 += inc1)
1882 if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
1883 return 0;
1884 return 1;
1885 case scm_tc7_uvect:
1886 case scm_tc7_ivect:
1887 {
1888 long *v0 = (long *) SCM_VELTS (ra0) + i0;
1889 long *v1 = (long *) SCM_VELTS (ra1) + i1;
1890 for (; n--; v0 += inc0, v1 += inc1)
1891 if (*v0 != *v1)
1892 return 0;
1893 return 1;
1894 }
1895 case scm_tc7_svect:
1896 {
1897 short *v0 = (short *) SCM_VELTS (ra0) + i0;
1898 short *v1 = (short *) SCM_VELTS (ra1) + i1;
1899 for (; n--; v0 += inc0, v1 += inc1)
1900 if (*v0 != *v1)
1901 return 0;
1902 return 1;
1903 }
1904 #ifdef HAVE_LONG_LONGS
1905 case scm_tc7_llvect:
1906 {
1907 long long *v0 = (long long *) SCM_VELTS (ra0) + i0;
1908 long long *v1 = (long long *) SCM_VELTS (ra1) + i1;
1909 for (; n--; v0 += inc0, v1 += inc1)
1910 if (*v0 != *v1)
1911 return 0;
1912 return 1;
1913 }
1914 #endif
1915 #ifdef SCM_FLOATS
1916 #ifdef SCM_SINGLES
1917 case scm_tc7_fvect:
1918 {
1919 float *v0 = (float *) SCM_VELTS (ra0) + i0;
1920 float *v1 = (float *) SCM_VELTS (ra1) + i1;
1921 for (; n--; v0 += inc0, v1 += inc1)
1922 if (*v0 != *v1)
1923 return 0;
1924 return 1;
1925 }
1926 #endif /* SCM_SINGLES */
1927 case scm_tc7_dvect:
1928 {
1929 double *v0 = (double *) SCM_VELTS (ra0) + i0;
1930 double *v1 = (double *) SCM_VELTS (ra1) + i1;
1931 for (; n--; v0 += inc0, v1 += inc1)
1932 if (*v0 != *v1)
1933 return 0;
1934 return 1;
1935 }
1936 case scm_tc7_cvect:
1937 {
1938 double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
1939 double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
1940 for (; n--; v0 += inc0, v1 += inc1)
1941 {
1942 if ((*v0)[0] != (*v1)[0])
1943 return 0;
1944 if ((*v0)[1] != (*v1)[1])
1945 return 0;
1946 }
1947 return 1;
1948 }
1949 #endif /* SCM_FLOATS */
1950 }
1951 }
1952
1953
1954
1955 static int
1956 raeql (SCM ra0,SCM as_equal,SCM ra1)
1957 {
1958 SCM v0 = ra0, v1 = ra1;
1959 scm_array_dim dim0, dim1;
1960 scm_array_dim *s0 = &dim0, *s1 = &dim1;
1961 scm_sizet bas0 = 0, bas1 = 0;
1962 int k, unroll = 1, vlen = 1, ndim = 1;
1963 if (SCM_ARRAYP (ra0))
1964 {
1965 ndim = SCM_ARRAY_NDIM (ra0);
1966 s0 = SCM_ARRAY_DIMS (ra0);
1967 bas0 = SCM_ARRAY_BASE (ra0);
1968 v0 = SCM_ARRAY_V (ra0);
1969 }
1970 else
1971 {
1972 s0->inc = 1;
1973 s0->lbnd = 0;
1974 s0->ubnd = SCM_LENGTH (v0) - 1;
1975 unroll = 0;
1976 }
1977 if (SCM_ARRAYP (ra1))
1978 {
1979 if (ndim != SCM_ARRAY_NDIM (ra1))
1980 return 0;
1981 s1 = SCM_ARRAY_DIMS (ra1);
1982 bas1 = SCM_ARRAY_BASE (ra1);
1983 v1 = SCM_ARRAY_V (ra1);
1984 }
1985 else
1986 {
1987 if (1 != ndim)
1988 return SCM_BOOL_F;
1989 s1->inc = 1;
1990 s1->lbnd = 0;
1991 s1->ubnd = SCM_LENGTH (v1) - 1;
1992 unroll = 0;
1993 }
1994 if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
1995 return 0;
1996 for (k = ndim; k--;)
1997 {
1998 if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
1999 return 0;
2000 if (unroll)
2001 {
2002 unroll = (s0[k].inc == s1[k].inc);
2003 vlen *= s0[k].ubnd - s1[k].lbnd + 1;
2004 }
2005 }
2006 if (unroll && bas0 == bas1 && v0 == v1)
2007 return SCM_BOOL_T;
2008 return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
2009 }
2010
2011
2012 SCM
2013 scm_raequal (SCM ra0, SCM ra1)
2014 {
2015 return SCM_BOOL(raeql (ra0, SCM_BOOL_T, ra1));
2016 }
2017
2018 static char s_array_equal_p[] = "array-equal?";
2019
2020
2021 SCM
2022 scm_array_equal_p (SCM ra0, SCM ra1)
2023 {
2024 if (SCM_IMP (ra0) || SCM_IMP (ra1))
2025 callequal:return scm_equal_p (ra0, ra1);
2026 switch (SCM_TYP7(ra0))
2027 {
2028 default:
2029 goto callequal;
2030 case scm_tc7_bvect:
2031 case scm_tc7_string:
2032 case scm_tc7_byvect:
2033 case scm_tc7_uvect:
2034 case scm_tc7_ivect:
2035 case scm_tc7_fvect:
2036 case scm_tc7_dvect:
2037 case scm_tc7_cvect:
2038 case scm_tc7_vector:
2039 case scm_tc7_wvect:
2040 break;
2041 case scm_tc7_smob:
2042 if (!SCM_ARRAYP (ra0))
2043 goto callequal;
2044 }
2045 switch (SCM_TYP7 (ra1))
2046 {
2047 default:
2048 goto callequal;
2049 case scm_tc7_bvect:
2050 case scm_tc7_string:
2051 case scm_tc7_byvect:
2052 case scm_tc7_uvect:
2053 case scm_tc7_ivect:
2054 case scm_tc7_fvect:
2055 case scm_tc7_dvect:
2056 case scm_tc7_cvect:
2057 case scm_tc7_vector:
2058 case scm_tc7_wvect:
2059 break;
2060 case scm_tc7_smob:
2061 if (!SCM_ARRAYP (ra1))
2062 goto callequal;
2063 }
2064 return SCM_BOOL(raeql (ra0, SCM_BOOL_F, ra1));
2065 }
2066
2067
2068
2069 static void
2070 init_raprocs (ra_iproc *subra)
2071 {
2072 for (; subra->name; subra++)
2073 subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
2074 }
2075
2076
2077 void
2078 scm_init_ramap ()
2079 {
2080 init_raprocs (ra_rpsubrs);
2081 init_raprocs (ra_asubrs);
2082 scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
2083 scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
2084 #include "ramap.x"
2085 scm_add_feature (s_scm_array_for_each);
2086 }
Unnamed repository; edit this file 'description' to name the repository.