1 /* Copyright (C) 1996 Free Software Foundation, Inc.
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)
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.
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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
67 static ra_iproc ra_rpsubrs
[];
68 static ra_iproc ra_asubrs
[];
70 #define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
71 #define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
72 #define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
74 /* Fast, recycling scm_vector ref */
75 #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
77 /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
79 /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
80 elements of scm_vector operands are not aliased */
82 #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
84 #define IVDEP(test, line) line
89 /* inds must be a uvect or ivect, no check. */
92 static scm_sizet cind
SCM_P ((SCM ra
, SCM inds
));
101 long *ve
= SCM_VELTS (inds
);
102 if (!SCM_ARRAYP (ra
))
104 i
= SCM_ARRAY_BASE (ra
);
105 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
106 i
+= (ve
[k
] - SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_ARRAY_DIMS (ra
)[k
].inc
;
111 /* Checker for scm_array mapping functions:
112 return values: 4 --> shapes, increments, and bases are the same;
113 3 --> shapes and increments are the same;
114 2 --> shapes are the same;
115 1 --> ras are at least as big as ra0;
120 scm_ra_matchp (ra0
, ras
)
126 scm_array_dim
*s0
= &dims
;
130 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
133 switch (SCM_TYP7 (ra0
))
147 s0
->ubnd
= (long) SCM_LENGTH (ra0
) - 1;
150 if (!SCM_ARRAYP (ra0
))
152 ndim
= SCM_ARRAY_NDIM (ra0
);
153 s0
= SCM_ARRAY_DIMS (ra0
);
154 bas0
= SCM_ARRAY_BASE (ra0
);
187 if ((0 == s0
->lbnd
) && (s0
->ubnd
== SCM_LENGTH (ra1
) - 1))
191 if (s0
->lbnd
< 0 || s0
->ubnd
>= SCM_LENGTH (ra1
))
196 if (!SCM_ARRAYP (ra1
) || ndim
!= SCM_ARRAY_NDIM (ra1
))
198 s1
= SCM_ARRAY_DIMS (ra1
);
199 if (bas0
!= SCM_ARRAY_BASE (ra1
))
201 for (i
= 0; i
< ndim
; i
++)
206 if (s0
[i
].inc
!= s1
[i
].inc
)
209 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
213 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
214 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
223 static char s_ra_mismatch
[] = "array shape mismatch";
226 scm_ramapc (cproc
, data
, ra0
, lra
, what
)
238 switch (scm_ra_matchp (ra0
, lra
))
242 scm_wta (ra0
, s_ra_mismatch
, what
);
245 case 4: /* Try unrolling arrays */
246 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
249 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
252 if (!SCM_ARRAYP (vra0
))
254 vra1
= scm_make_ra (1);
255 SCM_ARRAY_BASE (vra1
) = 0;
256 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
257 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_LENGTH (vra0
) - 1;
258 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
259 SCM_ARRAY_V (vra1
) = vra0
;
264 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
267 vra1
= scm_make_ra (1);
268 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
269 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
270 if (!SCM_ARRAYP (ra1
))
272 SCM_ARRAY_BASE (vra1
) = 0;
273 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
274 SCM_ARRAY_V (vra1
) = ra1
;
276 else if (!SCM_ARRAY_CONTP (ra1
))
280 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
281 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
282 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
284 *plvra
= scm_cons (vra1
, SCM_EOL
);
285 plvra
= SCM_CDRLOC (*plvra
);
287 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
289 gencase
: /* Have to loop over all dimensions. */
290 vra0
= scm_make_ra (1);
294 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
297 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
298 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
299 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
303 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
304 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
305 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
307 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
308 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
313 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
314 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_LENGTH (ra0
) - 1;
315 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
316 SCM_ARRAY_BASE (vra0
) = 0;
317 SCM_ARRAY_V (vra0
) = ra0
;
322 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
325 vra1
= scm_make_ra (1);
326 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
327 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
332 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
333 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
337 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
338 SCM_ARRAY_V (vra1
) = ra1
;
340 *plvra
= scm_cons (vra1
, SCM_EOL
);
341 plvra
= SCM_CDRLOC (*plvra
);
343 inds
= scm_make_uve (SCM_ARRAY_NDIM (ra0
), SCM_MAKINUM (-1L));
344 vinds
= (long *) SCM_VELTS (inds
);
345 for (k
= 0; k
<= kmax
; k
++)
346 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
353 SCM_ARRAY_BASE (vra0
) = cind (ra0
, inds
);
354 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
355 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), inds
);
356 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
361 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
367 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
376 static char s_array_fill_x
[];
379 scm_array_fill_int (ra
, fill
, ignore
)
384 scm_sizet i
, n
= SCM_ARRAY_DIMS (ra
)->ubnd
- SCM_ARRAY_DIMS (ra
)->lbnd
+ 1;
385 long inc
= SCM_ARRAY_DIMS (ra
)->inc
;
386 scm_sizet base
= SCM_ARRAY_BASE (ra
);
387 ra
= SCM_ARRAY_V (ra
);
392 for (i
= base
; n
--; i
+= inc
)
393 scm_array_set_x (ra
, fill
, SCM_MAKINUM (i
));
396 for (i
= base
; n
--; i
+= inc
)
397 SCM_VELTS (ra
)[i
] = fill
;
400 SCM_ASRTGO (SCM_ICHRP (fill
), badarg2
);
401 for (i
= base
; n
--; i
+= inc
)
402 SCM_CHARS (ra
)[i
] = SCM_ICHR (fill
);
406 long *ve
= (long *) SCM_VELTS (ra
);
407 if (1 == inc
&& (n
>= SCM_LONG_BIT
|| n
== SCM_LENGTH (ra
)))
409 i
= base
/ SCM_LONG_BIT
;
410 if (SCM_BOOL_F
== fill
)
412 if (base
% SCM_LONG_BIT
) /* leading partial word */
413 ve
[i
++] &= ~(~0L << (base
% SCM_LONG_BIT
));
414 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
416 if ((base
+ n
) % SCM_LONG_BIT
) /* trailing partial word */
417 ve
[i
] &= (~0L << ((base
+ n
) % SCM_LONG_BIT
));
419 else if (SCM_BOOL_T
== fill
)
421 if (base
% SCM_LONG_BIT
)
422 ve
[i
++] |= ~0L << (base
% SCM_LONG_BIT
);
423 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
425 if ((base
+ n
) % SCM_LONG_BIT
)
426 ve
[i
] |= ~(~0L << ((base
+ n
) % SCM_LONG_BIT
));
429 badarg2
:scm_wta (fill
, (char *) SCM_ARG2
, s_array_fill_x
);
433 if (SCM_BOOL_F
== fill
)
434 for (i
= base
; n
--; i
+= inc
)
435 ve
[i
/ SCM_LONG_BIT
] &= ~(1L << (i
% SCM_LONG_BIT
));
436 else if (SCM_BOOL_T
== fill
)
437 for (i
= base
; n
--; i
+= inc
)
438 ve
[i
/ SCM_LONG_BIT
] |= (1L << (i
% SCM_LONG_BIT
));
445 SCM_ASRTGO (0 <= SCM_INUM (fill
), badarg2
);
447 SCM_ASRTGO (SCM_INUMP (fill
), badarg2
);
449 long f
= SCM_INUM (fill
), *ve
= (long *) SCM_VELTS (ra
);
450 for (i
= base
; n
--; i
+= inc
)
458 float f
, *ve
= (float *) SCM_VELTS (ra
);
459 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_REALP (fill
), badarg2
);
460 f
= SCM_REALPART (fill
);
461 for (i
= base
; n
--; i
+= inc
)
465 #endif /* SCM_SINGLES */
468 double f
, *ve
= (double *) SCM_VELTS (ra
);
469 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_REALP (fill
), badarg2
);
470 f
= SCM_REALPART (fill
);
471 for (i
= base
; n
--; i
+= inc
)
478 double (*ve
)[2] = (double (*)[2]) SCM_VELTS (ra
);
479 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_INEXP (fill
), badarg2
);
480 fr
= SCM_REALPART (fill
);
481 fi
= (SCM_CPLXP (fill
) ? SCM_IMAG (fill
) : 0.0);
482 for (i
= base
; n
--; i
+= inc
)
489 #endif /* SCM_FLOATS */
494 SCM_PROC(s_array_fill_x
, "array-fill!", 2, 0, 0, scm_array_fill_x
);
497 scm_array_fill_x (ra
, fill
)
501 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, s_array_fill_x
);
502 return SCM_UNSPECIFIED
;
508 static int racp
SCM_P ((SCM dst
, SCM src
));
515 long n
= (SCM_ARRAY_DIMS (src
)->ubnd
- SCM_ARRAY_DIMS (src
)->lbnd
+ 1);
516 long inc_d
, inc_s
= SCM_ARRAY_DIMS (src
)->inc
;
517 scm_sizet i_d
, i_s
= SCM_ARRAY_BASE (src
);
519 inc_d
= SCM_ARRAY_DIMS (dst
)->inc
;
520 i_d
= SCM_ARRAY_BASE (dst
);
521 src
= SCM_ARRAY_V (src
);
522 dst
= SCM_ARRAY_V (dst
);
527 gencase
: case scm_tc7_vector
:
528 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
529 scm_array_set_x (dst
, scm_cvref (src
, i_s
, SCM_UNDEFINED
), SCM_MAKINUM (i_d
));
532 if (scm_tc7_string
!= SCM_TYP7 (dst
))
534 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
535 SCM_CHARS (dst
)[i_d
] = SCM_CHARS (src
)[i_s
];
538 if (scm_tc7_bvect
!= SCM_TYP7 (dst
))
540 if (1 == inc_d
&& 1 == inc_s
&& i_s
% SCM_LONG_BIT
== i_d
% SCM_LONG_BIT
&& n
>= SCM_LONG_BIT
)
542 long *sv
= (long *) SCM_VELTS (src
);
543 long *dv
= (long *) SCM_VELTS (dst
);
544 sv
+= i_s
/ SCM_LONG_BIT
;
545 dv
+= i_d
/ SCM_LONG_BIT
;
546 if (i_s
% SCM_LONG_BIT
)
547 { /* leading partial word */
548 *dv
= (*dv
& ~(~0L << (i_s
% SCM_LONG_BIT
))) | (*sv
& (~0L << (i_s
% SCM_LONG_BIT
)));
551 n
-= SCM_LONG_BIT
- (i_s
% SCM_LONG_BIT
);
554 for (; n
>= SCM_LONG_BIT
; n
-= SCM_LONG_BIT
, sv
++, dv
++)
556 if (n
) /* trailing partial word */
557 *dv
= (*dv
& (~0L << n
)) | (*sv
& ~(~0L << n
));
561 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
562 if (SCM_VELTS (src
)[i_s
/ SCM_LONG_BIT
] & (1L << (i_s
% SCM_LONG_BIT
)))
563 SCM_VELTS (dst
)[i_d
/ SCM_LONG_BIT
] |= (1L << (i_d
% SCM_LONG_BIT
));
565 SCM_VELTS (dst
)[i_d
/ SCM_LONG_BIT
] &= ~(1L << (i_d
% SCM_LONG_BIT
));
569 if (scm_tc7_uvect
!= SCM_TYP7 (src
))
573 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
575 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
580 if (scm_tc7_uvect
!= SCM_TYP7 (src
) && scm_tc7_ivect
!= SCM_TYP7 (src
))
584 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
586 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
594 float *d
= (float *) SCM_VELTS (dst
);
595 float *s
= (float *) SCM_VELTS (src
);
604 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
605 d
[i_d
] = ((long *) s
)[i_s
];)
609 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
614 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
615 d
[i_d
] = ((double *) s
)[i_s
];)
620 #endif /* SCM_SINGLES */
623 double *d
= (double *) SCM_VELTS (dst
);
624 double *s
= (double *) SCM_VELTS (src
);
633 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
634 d
[i_d
] = ((long *) s
)[i_s
];)
638 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
639 d
[i_d
] = ((float *) s
)[i_s
];)
643 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
651 double (*d
)[2] = (double (*)[2]) SCM_VELTS (dst
);
652 double (*s
)[2] = (double (*)[2]) SCM_VELTS (src
);
661 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
663 d
[i_d
][0] = ((long *) s
)[i_s
];
670 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
672 d
[i_d
][0] = ((float *) s
)[i_s
];
679 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
681 d
[i_d
][0] = ((double *) s
)[i_s
];
688 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
690 d
[i_d
][0] = s
[i_s
][0];
691 d
[i_d
][1] = s
[i_s
][1];
698 #endif /* SCM_FLOATS */
703 SCM_PROC(s_serial_array_copy_x
, "serial-array-copy!", 2, 0, 0, scm_array_copy_x
);
704 SCM_PROC(s_array_copy_x
, "array-copy!", 2, 0, 0, scm_array_copy_x
);
707 scm_array_copy_x (src
, dst
)
711 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), s_array_copy_x
);
712 return SCM_UNSPECIFIED
;
715 /* Functions callable by ARRAY-MAP! */
719 scm_ra_eqp (ra0
, ras
)
723 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
724 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
725 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
726 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
727 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
728 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
729 ra0
= SCM_ARRAY_V (ra0
);
730 ra1
= SCM_ARRAY_V (ra1
);
731 ra2
= SCM_ARRAY_V (ra2
);
732 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
736 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
737 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
741 (scm_eq_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)))
747 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
750 if (SCM_VELTS (ra1
)[i1
] != SCM_VELTS (ra2
)[i2
])
756 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
759 if (((float *) SCM_VELTS (ra1
))[i1
] != ((float *) SCM_VELTS (ra2
))[i2
])
762 #endif /*SCM_SINGLES*/
764 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
767 if (((double *) SCM_VELTS (ra1
))[i1
] != ((double *) SCM_VELTS (ra2
))[i2
])
771 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
774 if (((double *) SCM_VELTS (ra1
))[2 * i1
] != ((double *) SCM_VELTS (ra2
))[2 * i2
] ||
775 ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1] != ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1])
778 #endif /*SCM_FLOATS*/
783 /* opt 0 means <, nonzero means >= */
785 static int ra_compare
SCM_P ((SCM ra0
, SCM ra1
, SCM ra2
, int opt
));
788 ra_compare (ra0
, ra1
, ra2
, opt
)
794 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
795 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
796 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
797 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
798 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
799 ra0
= SCM_ARRAY_V (ra0
);
800 ra1
= SCM_ARRAY_V (ra1
);
801 ra2
= SCM_ARRAY_V (ra2
);
802 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
806 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
807 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
811 SCM_NFALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))) :
812 SCM_FALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
818 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
823 SCM_VELTS (ra1
)[i1
] < SCM_VELTS (ra2
)[i2
] :
824 SCM_VELTS (ra1
)[i1
] >= SCM_VELTS (ra2
)[i2
])
831 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
835 ((float *) SCM_VELTS (ra1
))[i1
] < ((float *) SCM_VELTS (ra2
))[i2
] :
836 ((float *) SCM_VELTS (ra1
))[i1
] >= ((float *) SCM_VELTS (ra2
))[i2
])
839 #endif /*SCM_SINGLES*/
841 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
845 ((double *) SCM_VELTS (ra1
))[i1
] < ((double *) SCM_VELTS (ra2
))[i2
] :
846 ((double *) SCM_VELTS (ra1
))[i1
] >= ((double *) SCM_VELTS (ra2
))[i2
])
849 #endif /*SCM_FLOATS*/
857 scm_ra_lessp (ra0
, ras
)
861 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
866 scm_ra_leqp (ra0
, ras
)
870 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
875 scm_ra_grp (ra0
, ras
)
879 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
884 scm_ra_greqp (ra0
, ras
)
888 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
894 scm_ra_sum (ra0
, ras
)
898 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
899 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
900 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
901 ra0
= SCM_ARRAY_V (ra0
);
905 SCM ra1
= SCM_CAR (ras
);
906 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
907 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
908 ra1
= SCM_ARRAY_V (ra1
);
909 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
913 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
914 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
915 scm_array_set_x (ra0
, scm_sum (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
922 long *v0
= SCM_VELTS (ra0
);
923 long *v1
= SCM_VELTS (ra1
);
925 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
933 float *v0
= (float *) SCM_VELTS (ra0
);
934 float *v1
= (float *) SCM_VELTS (ra1
);
936 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
940 #endif /* SCM_SINGLES */
943 double *v0
= (double *) SCM_VELTS (ra0
);
944 double *v1
= (double *) SCM_VELTS (ra1
);
946 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
952 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
953 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
955 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
957 v0
[i0
][0] += v1
[i1
][0];
958 v0
[i0
][1] += v1
[i1
][1];
963 #endif /* SCM_FLOATS */
972 scm_ra_difference (ra0
, ras
)
976 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
977 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
978 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
979 ra0
= SCM_ARRAY_V (ra0
);
988 SCM e0
= SCM_UNDEFINED
;
989 for (; n
-- > 0; i0
+= inc0
)
990 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
997 float *v0
= (float *) SCM_VELTS (ra0
);
998 for (; n
-- > 0; i0
+= inc0
)
1002 #endif /* SCM_SINGLES */
1005 double *v0
= (double *) SCM_VELTS (ra0
);
1006 for (; n
-- > 0; i0
+= inc0
)
1012 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1013 for (; n
-- > 0; i0
+= inc0
)
1015 v0
[i0
][0] = -v0
[i0
][0];
1016 v0
[i0
][1] = -v0
[i0
][1];
1020 #endif /* SCM_FLOATS */
1025 SCM ra1
= SCM_CAR (ras
);
1026 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1027 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1028 ra1
= SCM_ARRAY_V (ra1
);
1029 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1033 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1034 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1035 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1042 float *v0
= (float *) SCM_VELTS (ra0
);
1043 float *v1
= (float *) SCM_VELTS (ra1
);
1045 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1049 #endif /* SCM_SINGLES */
1052 double *v0
= (double *) SCM_VELTS (ra0
);
1053 double *v1
= (double *) SCM_VELTS (ra1
);
1055 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1061 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1062 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1064 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1066 v0
[i0
][0] -= v1
[i1
][0];
1067 v0
[i0
][1] -= v1
[i1
][1];
1072 #endif /* SCM_FLOATS */
1081 scm_ra_product (ra0
, ras
)
1085 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1086 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1087 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1088 ra0
= SCM_ARRAY_V (ra0
);
1092 SCM ra1
= SCM_CAR (ras
);
1093 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1094 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1095 ra1
= SCM_ARRAY_V (ra1
);
1096 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1100 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1101 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1102 scm_array_set_x (ra0
, scm_product (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1109 long *v0
= SCM_VELTS (ra0
);
1110 long *v1
= SCM_VELTS (ra1
);
1112 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1120 float *v0
= (float *) SCM_VELTS (ra0
);
1121 float *v1
= (float *) SCM_VELTS (ra1
);
1123 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1127 #endif /* SCM_SINGLES */
1130 double *v0
= (double *) SCM_VELTS (ra0
);
1131 double *v1
= (double *) SCM_VELTS (ra1
);
1133 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1139 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1141 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1143 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1145 r
= v0
[i0
][0] * v1
[i1
][0] - v0
[i0
][1] * v1
[i1
][1];
1146 v0
[i0
][1] = v0
[i0
][0] * v1
[i1
][1] + v0
[i0
][1] * v1
[i1
][0];
1152 #endif /* SCM_FLOATS */
1160 scm_ra_divide (ra0
, ras
)
1164 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1165 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1166 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1167 ra0
= SCM_ARRAY_V (ra0
);
1176 SCM e0
= SCM_UNDEFINED
;
1177 for (; n
-- > 0; i0
+= inc0
)
1178 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1185 float *v0
= (float *) SCM_VELTS (ra0
);
1186 for (; n
-- > 0; i0
+= inc0
)
1187 v0
[i0
] = 1.0 / v0
[i0
];
1190 #endif /* SCM_SINGLES */
1193 double *v0
= (double *) SCM_VELTS (ra0
);
1194 for (; n
-- > 0; i0
+= inc0
)
1195 v0
[i0
] = 1.0 / v0
[i0
];
1201 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1202 for (; n
-- > 0; i0
+= inc0
)
1204 d
= v0
[i0
][0] * v0
[i0
][0] + v0
[i0
][1] * v0
[i0
][1];
1210 #endif /* SCM_FLOATS */
1215 SCM ra1
= SCM_CAR (ras
);
1216 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1217 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1218 ra1
= SCM_ARRAY_V (ra1
);
1219 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1223 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1224 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1225 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1232 float *v0
= (float *) SCM_VELTS (ra0
);
1233 float *v1
= (float *) SCM_VELTS (ra1
);
1235 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1239 #endif /* SCM_SINGLES */
1242 double *v0
= (double *) SCM_VELTS (ra0
);
1243 double *v1
= (double *) SCM_VELTS (ra1
);
1245 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1251 register double d
, r
;
1252 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1253 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1255 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1257 d
= v1
[i1
][0] * v1
[i1
][0] + v1
[i1
][1] * v1
[i1
][1];
1258 r
= (v0
[i0
][0] * v1
[i1
][0] + v0
[i0
][1] * v1
[i1
][1]) / d
;
1259 v0
[i0
][1] = (v0
[i0
][1] * v1
[i1
][0] - v0
[i0
][0] * v1
[i1
][1]) / d
;
1265 #endif /* SCM_FLOATS */
1273 scm_array_identity (dst
, src
)
1277 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
1282 static int ramap
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1285 ramap (ra0
, proc
, ras
)
1290 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1291 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
1292 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1293 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
1294 ra0
= SCM_ARRAY_V (ra0
);
1298 scm_array_set_x (ra0
, scm_apply (proc
, SCM_EOL
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1301 SCM ra1
= SCM_CAR (ras
);
1302 SCM args
, *ve
= &ras
;
1303 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1304 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1305 ra1
= SCM_ARRAY_V (ra1
);
1306 ras
= SCM_CDR (ras
);
1312 ras
= scm_vector (ras
);
1313 ve
= SCM_VELTS (ras
);
1315 for (; i
<= n
; i
++, i1
+= inc1
)
1318 for (k
= SCM_LENGTH (ras
); k
--;)
1319 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1320 args
= scm_cons (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1321 scm_array_set_x (ra0
, scm_apply (proc
, args
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1328 static int ramap_cxr
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1331 ramap_cxr (ra0
, proc
, ras
)
1336 SCM ra1
= SCM_CAR (ras
);
1337 SCM e1
= SCM_UNDEFINED
;
1338 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1339 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1340 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
1341 ra0
= SCM_ARRAY_V (ra0
);
1342 ra1
= SCM_ARRAY_V (ra1
);
1348 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1349 scm_array_set_x (ra0
, scm_apply (proc
, RVREF (ra1
, i1
, e1
), scm_listofnull
), SCM_MAKINUM (i0
));
1355 float *dst
= (float *) SCM_VELTS (ra0
);
1362 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1363 dst
[i0
] = SCM_DSUBRF (proc
) ((double) ((float *) SCM_VELTS (ra1
))[i1
]);
1367 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1368 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1373 #endif /* SCM_SINGLES */
1376 double *dst
= (double *) SCM_VELTS (ra0
);
1383 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1384 dst
[i0
] = SCM_DSUBRF (proc
) (((double *) SCM_VELTS (ra1
))[i1
]);
1388 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1389 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1394 #endif /* SCM_FLOATS */
1401 static int ramap_rp
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1404 ramap_rp (ra0
, proc
, ras
)
1409 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
1410 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
1411 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1412 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
1413 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1414 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1415 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
1416 ra0
= SCM_ARRAY_V (ra0
);
1417 ra1
= SCM_ARRAY_V (ra1
);
1418 ra2
= SCM_ARRAY_V (ra2
);
1419 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
1422 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1426 (SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)))
1431 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1436 (SCM_SUBRF (proc
) (SCM_MAKINUM (SCM_VELTS (ra1
)[i1
]),
1437 SCM_MAKINUM (SCM_VELTS (ra2
)[i2
])))
1445 SCM a1
= scm_makflo (1.0), a2
= scm_makflo (1.0);
1446 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1450 SCM_FLO (a1
) = ((float *) SCM_VELTS (ra1
))[i1
];
1451 SCM_FLO (a2
) = ((float *) SCM_VELTS (ra2
))[i2
];
1453 (SCM_SUBRF (proc
) (a1
, a2
))
1458 #endif /*SCM_SINGLES*/
1461 SCM a1
= scm_makdbl (1.0 / 3.0, 0.0), a2
= scm_makdbl (1.0 / 3.0, 0.0);
1462 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1466 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[i1
];
1467 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[i2
];
1469 (SCM_SUBRF (proc
) (a1
, a2
))
1476 SCM a1
= scm_makdbl (1.0, 1.0), a2
= scm_makdbl (1.0, 1.0);
1477 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1481 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
];
1482 SCM_IMAG (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1];
1483 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
];
1484 SCM_IMAG (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1];
1486 (SCM_SUBRF (proc
) (a1
, a2
))
1491 #endif /*SCM_FLOATS*/
1498 static int ramap_1
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1501 ramap_1 (ra0
, proc
, ras
)
1506 SCM ra1
= SCM_CAR (ras
);
1507 SCM e1
= SCM_UNDEFINED
;
1508 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1509 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1510 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1511 ra0
= SCM_ARRAY_V (ra0
);
1512 ra1
= SCM_ARRAY_V (ra1
);
1513 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1514 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1515 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
)), SCM_MAKINUM (i0
));
1517 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1518 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1524 static int ramap_2o
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1527 ramap_2o (ra0
, proc
, ras
)
1532 SCM ra1
= SCM_CAR (ras
);
1533 SCM e1
= SCM_UNDEFINED
;
1534 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1535 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1536 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1537 ra0
= SCM_ARRAY_V (ra0
);
1538 ra1
= SCM_ARRAY_V (ra1
);
1539 ras
= SCM_CDR (ras
);
1543 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1544 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1545 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), SCM_UNDEFINED
),
1548 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1549 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), SCM_UNDEFINED
),
1554 SCM ra2
= SCM_CAR (ras
);
1555 SCM e2
= SCM_UNDEFINED
;
1556 scm_sizet i2
= SCM_ARRAY_BASE (ra2
);
1557 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
1558 ra2
= SCM_ARRAY_V (ra2
);
1559 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1560 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1561 scm_array_set_x (ra0
,
1562 SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), scm_cvref (ra2
, i2
, SCM_UNDEFINED
)),
1565 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1566 scm_array_set_x (ra0
,
1567 SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)),
1575 static int ramap_a
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1578 ramap_a (ra0
, proc
, ras
)
1583 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1584 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1585 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1586 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1587 ra0
= SCM_ARRAY_V (ra0
);
1590 for (; n
-- > 0; i0
+= inc0
)
1591 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1594 SCM ra1
= SCM_CAR (ras
);
1595 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1596 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1597 ra1
= SCM_ARRAY_V (ra1
);
1598 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1599 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1605 SCM_PROC(s_serial_array_map
, "serial-array-map", 2, 0, 1, scm_array_map
);
1606 SCM_PROC(s_array_map
, "array-map", 2, 0, 1, scm_array_map
);
1609 scm_array_map (ra0
, proc
, lra
)
1614 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG2
, s_array_map
);
1615 switch (SCM_TYP7 (proc
))
1619 scm_ramapc (ramap
, proc
, ra0
, lra
, s_array_map
);
1620 return SCM_UNSPECIFIED
;
1621 case scm_tc7_subr_1
:
1622 scm_ramapc (ramap_1
, proc
, ra0
, lra
, s_array_map
);
1623 return SCM_UNSPECIFIED
;
1624 case scm_tc7_subr_2
:
1625 case scm_tc7_subr_2o
:
1626 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, s_array_map
);
1627 return SCM_UNSPECIFIED
;
1629 if (!SCM_SUBRF (proc
))
1631 scm_ramapc (ramap_cxr
, proc
, ra0
, lra
, s_array_map
);
1632 return SCM_UNSPECIFIED
;
1633 case scm_tc7_rpsubr
:
1636 if (SCM_FALSEP (scm_array_p (ra0
, SCM_BOOL_T
)))
1638 scm_array_fill_x (ra0
, SCM_BOOL_T
);
1639 for (p
= ra_rpsubrs
; p
->name
; p
++)
1640 if (proc
== p
->sproc
)
1642 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1644 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, s_array_map
);
1645 lra
= SCM_CDR (lra
);
1647 return SCM_UNSPECIFIED
;
1649 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1651 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, s_array_map
);
1652 lra
= SCM_CDR (lra
);
1654 return SCM_UNSPECIFIED
;
1660 SCM prot
, fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
1664 prot
= scm_array_prototype (ra0
);
1665 if (SCM_NIMP (prot
) && SCM_INEXP (prot
))
1666 fill
= scm_makdbl ((double) SCM_INUM (fill
), 0.0);
1669 scm_array_fill_x (ra0
, fill
);
1673 SCM tail
, ra1
= SCM_CAR (lra
);
1674 SCM v0
= (SCM_NIMP (ra0
) && SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
1676 /* Check to see if order might matter.
1677 This might be an argument for a separate
1678 SERIAL-ARRAY-MAP! */
1679 if (v0
== ra1
|| (SCM_NIMP (ra1
) && SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1680 if (ra0
!= ra1
|| (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
1682 for (tail
= SCM_CDR (lra
); SCM_NNULLP (tail
); tail
= SCM_CDR (tail
))
1684 ra1
= SCM_CAR (tail
);
1685 if (v0
== ra1
|| (SCM_NIMP (ra1
) && SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1688 for (p
= ra_asubrs
; p
->name
; p
++)
1689 if (proc
== p
->sproc
)
1691 if (ra0
!= SCM_CAR (lra
))
1692 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), s_array_map
);
1693 lra
= SCM_CDR (lra
);
1696 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, s_array_map
);
1697 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
1698 return SCM_UNSPECIFIED
;
1699 lra
= SCM_CDR (lra
);
1702 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, s_array_map
);
1703 lra
= SCM_CDR (lra
);
1706 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
1707 scm_ramapc (ramap_a
, proc
, ra0
, lra
, s_array_map
);
1709 return SCM_UNSPECIFIED
;
1714 static int rafe
SCM_P ((SCM ra0
, SCM proc
, SCM ras
));
1717 rafe (ra0
, proc
, ras
)
1722 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1723 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1724 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1725 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1726 ra0
= SCM_ARRAY_V (ra0
);
1729 for (; i
<= n
; i
++, i0
+= inc0
)
1730 scm_apply (proc
, scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_listofnull
);
1733 SCM ra1
= SCM_CAR (ras
);
1734 SCM args
, *ve
= &ras
;
1735 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1736 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1737 ra1
= SCM_ARRAY_V (ra1
);
1738 ras
= SCM_CDR (ras
);
1744 ras
= scm_vector (ras
);
1745 ve
= SCM_VELTS (ras
);
1747 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
1750 for (k
= SCM_LENGTH (ras
); k
--;)
1751 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1752 args
= scm_cons2 (scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1753 scm_apply (proc
, args
, SCM_EOL
);
1760 SCM_PROC(s_array_for_each
, "array-for-each", 2, 0, 1, scm_array_for_each
);
1763 scm_array_for_each (proc
, ra0
, lra
)
1768 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG1
, s_array_for_each
);
1769 scm_ramapc (rafe
, proc
, ra0
, lra
, s_array_for_each
);
1770 return SCM_UNSPECIFIED
;
1773 SCM_PROC(s_array_index_map_x
, "array-index-map!", 2, 0, 0, scm_array_index_map_x
);
1776 scm_array_index_map_x (ra
, proc
)
1781 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, s_array_index_map_x
);
1782 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG2
, s_array_index_map_x
);
1787 badarg
:scm_wta (ra
, (char *) SCM_ARG1
, s_array_index_map_x
);
1788 case scm_tc7_vector
:
1790 SCM
*ve
= SCM_VELTS (ra
);
1791 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1792 ve
[i
] = scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
);
1793 return SCM_UNSPECIFIED
;
1795 case scm_tc7_string
:
1802 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1803 scm_array_set_x (ra
, scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
), SCM_MAKINUM (i
));
1804 return SCM_UNSPECIFIED
;
1806 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
1809 SCM inds
= scm_make_uve (SCM_ARRAY_NDIM (ra
), SCM_MAKINUM (-1L));
1810 long *vinds
= SCM_VELTS (inds
);
1811 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
1812 for (k
= 0; k
<= kmax
; k
++)
1813 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1819 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1820 i
= cind (ra
, inds
);
1821 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1823 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1824 args
= scm_cons (SCM_MAKINUM (vinds
[j
]), args
);
1825 scm_array_set_x (SCM_ARRAY_V (ra
), scm_apply (proc
, args
, SCM_EOL
), SCM_MAKINUM (i
));
1826 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1831 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1837 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1841 return SCM_UNSPECIFIED
;
1847 static int raeql_1
SCM_P ((SCM ra0
, SCM as_equal
, SCM ra1
));
1850 raeql_1 (ra0
, as_equal
, ra1
)
1855 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1856 scm_sizet i0
= 0, i1
= 0;
1857 long inc0
= 1, inc1
= 1;
1858 scm_sizet n
= SCM_LENGTH (ra0
);
1859 ra1
= SCM_CAR (ra1
);
1863 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1864 i0
= SCM_ARRAY_BASE (ra0
);
1865 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1866 ra0
= SCM_ARRAY_V (ra0
);
1871 i1
= SCM_ARRAY_BASE (ra1
);
1872 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1873 ra1
= SCM_ARRAY_V (ra1
);
1878 case scm_tc7_vector
:
1880 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1886 (scm_array_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)))
1890 (scm_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)))
1894 case scm_tc7_string
:
1896 char *v0
= SCM_CHARS (ra0
) + i0
;
1897 char *v1
= SCM_CHARS (ra1
) + i1
;
1898 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1904 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1905 if (BVE_REF (ra0
, i0
) != BVE_REF (ra1
, i1
))
1911 long *v0
= (long *) SCM_VELTS (ra0
) + i0
;
1912 long *v1
= (long *) SCM_VELTS (ra1
) + i1
;
1913 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1922 float *v0
= (float *) SCM_VELTS (ra0
) + i0
;
1923 float *v1
= (float *) SCM_VELTS (ra1
) + i1
;
1924 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1929 #endif /* SCM_SINGLES */
1932 double *v0
= (double *) SCM_VELTS (ra0
) + i0
;
1933 double *v1
= (double *) SCM_VELTS (ra1
) + i1
;
1934 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1941 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
) + i0
;
1942 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
) + i1
;
1943 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1945 if ((*v0
)[0] != (*v1
)[0])
1947 if ((*v0
)[1] != (*v1
)[1])
1952 #endif /* SCM_FLOATS */
1958 static int raeql
SCM_P ((SCM ra0
, SCM as_equal
, SCM ra1
));
1961 raeql (ra0
, as_equal
, ra1
)
1966 SCM v0
= ra0
, v1
= ra1
;
1967 scm_array_dim dim0
, dim1
;
1968 scm_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1969 scm_sizet bas0
= 0, bas1
= 0;
1970 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1974 ndim
= SCM_ARRAY_NDIM (ra0
);
1975 s0
= SCM_ARRAY_DIMS (ra0
);
1976 bas0
= SCM_ARRAY_BASE (ra0
);
1977 v0
= SCM_ARRAY_V (ra0
);
1983 s0
->ubnd
= SCM_LENGTH (v0
) - 1;
1989 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
1991 s1
= SCM_ARRAY_DIMS (ra1
);
1992 bas1
= SCM_ARRAY_BASE (ra1
);
1993 v1
= SCM_ARRAY_V (ra1
);
2001 s1
->ubnd
= SCM_LENGTH (v1
) - 1;
2004 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
2006 for (k
= ndim
; k
--;)
2008 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
2012 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
2013 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
2016 if (unroll
&& bas0
== bas1
&& v0
== v1
)
2018 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
2023 scm_raequal (ra0
, ra1
)
2027 return (raeql (ra0
, SCM_BOOL_T
, ra1
) ? SCM_BOOL_T
: SCM_BOOL_F
);
2030 static char s_array_equal_p
[] = "array-equal?";
2034 scm_array_equal_p (ra0
, ra1
)
2038 if (SCM_IMP (ra0
) || SCM_IMP (ra1
))
2039 callequal
:return scm_equal_p (ra0
, ra1
);
2046 case scm_tc7_string
:
2052 case scm_tc7_vector
:
2055 if (!SCM_ARRAYP (ra0
))
2064 case scm_tc7_string
:
2070 case scm_tc7_vector
:
2073 if (!SCM_ARRAYP (ra1
))
2076 return (raeql (ra0
, SCM_BOOL_F
, ra1
) ? SCM_BOOL_T
: SCM_BOOL_F
);
2082 /* These tables are a kluge that will not scale well when more
2083 * vectorized subrs are added. It is tempting to steal some bits from
2084 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
2085 * offset into a table of vectorized subrs.
2088 static ra_iproc ra_rpsubrs
[] =
2090 {"=", SCM_UNDEFINED
, scm_ra_eqp
},
2091 {"<", SCM_UNDEFINED
, scm_ra_lessp
},
2092 {"<=", SCM_UNDEFINED
, scm_ra_leqp
},
2093 {">", SCM_UNDEFINED
, scm_ra_grp
},
2094 {">=", SCM_UNDEFINED
, scm_ra_greqp
},
2098 static ra_iproc ra_asubrs
[] =
2100 {"+", SCM_UNDEFINED
, scm_ra_sum
},
2101 {"-", SCM_UNDEFINED
, scm_ra_difference
},
2102 {"*", SCM_UNDEFINED
, scm_ra_product
},
2103 {"/", SCM_UNDEFINED
, scm_ra_divide
},
2108 init_raprocs (subra
)
2111 for (; subra
->name
; subra
++)
2112 subra
->sproc
= SCM_CDR (scm_intern (subra
->name
, strlen (subra
->name
)));
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
;
2124 scm_add_feature (s_array_for_each
);