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.
60 static ra_iproc ra_rpsubrs
[];
61 static ra_iproc ra_asubrs
[];
63 #define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
64 #define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
65 #define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
67 /* Fast, recycling scm_vector ref */
68 #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
70 /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
72 /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
73 elements of scm_vector operands are not aliased */
75 #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
77 #define IVDEP(test, line) line
82 /* inds must be a uvect or ivect, no check. */
86 cind (SCM ra
, SCM inds
)
96 long *ve
= SCM_VELTS (inds
);
99 i
= SCM_ARRAY_BASE (ra
);
100 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
101 i
+= (ve
[k
] - SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_ARRAY_DIMS (ra
)[k
].inc
;
106 /* Checker for scm_array mapping functions:
107 return values: 4 --> shapes, increments, and bases are the same;
108 3 --> shapes and increments are the same;
109 2 --> shapes are the same;
110 1 --> ras are at least as big as ra0;
115 scm_ra_matchp (SCM ra0
, SCM ras
)
118 scm_ra_matchp (ra0
, ras
)
125 scm_array_dim
*s0
= &dims
;
129 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
132 switch (SCM_TYP7 (ra0
))
146 s0
->ubnd
= (long) SCM_LENGTH (ra0
) - 1;
149 if (!SCM_ARRAYP (ra0
))
151 ndim
= SCM_ARRAY_NDIM (ra0
);
152 s0
= SCM_ARRAY_DIMS (ra0
);
153 bas0
= SCM_ARRAY_BASE (ra0
);
186 if ((0 == s0
->lbnd
) && (s0
->ubnd
== SCM_LENGTH (ra1
) - 1))
190 if (s0
->lbnd
< 0 || s0
->ubnd
>= SCM_LENGTH (ra1
))
195 if (!SCM_ARRAYP (ra1
) || ndim
!= SCM_ARRAY_NDIM (ra1
))
197 s1
= SCM_ARRAY_DIMS (ra1
);
198 if (bas0
!= SCM_ARRAY_BASE (ra1
))
200 for (i
= 0; i
< ndim
; i
++)
205 if (s0
[i
].inc
!= s1
[i
].inc
)
208 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
212 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
213 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
222 static char s_ra_mismatch
[] = "array shape mismatch";
226 scm_ramapc (int (*cproc
) (), SCM data
, SCM ra0
, SCM lra
, char *what
)
229 scm_ramapc (cproc
, data
, ra0
, lra
, what
)
242 switch (scm_ra_matchp (ra0
, lra
))
246 scm_wta (ra0
, s_ra_mismatch
, what
);
249 case 4: /* Try unrolling arrays */
250 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
253 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
256 if (!SCM_ARRAYP (vra0
))
258 vra1
= scm_make_ra (1);
259 SCM_ARRAY_BASE (vra1
) = 0;
260 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
261 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_LENGTH (vra0
) - 1;
262 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
263 SCM_ARRAY_V (vra1
) = vra0
;
268 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
271 vra1
= scm_make_ra (1);
272 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
273 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
274 if (!SCM_ARRAYP (ra1
))
276 SCM_ARRAY_BASE (vra1
) = 0;
277 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
278 SCM_ARRAY_V (vra1
) = ra1
;
280 else if (!SCM_ARRAY_CONTP (ra1
))
284 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
285 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
286 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
288 *plvra
= scm_cons (vra1
, SCM_EOL
);
289 plvra
= &SCM_CDR (*plvra
);
291 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
293 gencase
: /* Have to loop over all dimensions. */
294 vra0
= scm_make_ra (1);
298 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
301 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
302 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
303 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
307 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
308 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
309 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
311 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
312 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
317 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
318 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_LENGTH (ra0
) - 1;
319 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
320 SCM_ARRAY_BASE (vra0
) = 0;
321 SCM_ARRAY_V (vra0
) = ra0
;
326 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
329 vra1
= scm_make_ra (1);
330 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
331 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
336 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
337 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
341 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
342 SCM_ARRAY_V (vra1
) = ra1
;
344 *plvra
= scm_cons (vra1
, SCM_EOL
);
345 plvra
= &SCM_CDR (*plvra
);
347 inds
= scm_make_uve (SCM_ARRAY_NDIM (ra0
), SCM_MAKINUM (-1L));
348 vinds
= (long *) SCM_VELTS (inds
);
349 for (k
= 0; k
<= kmax
; k
++)
350 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
357 SCM_ARRAY_BASE (vra0
) = cind (ra0
, inds
);
358 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
359 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), inds
);
360 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
365 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
371 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
380 static char s_array_fill_x
[];
383 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore
)
386 scm_array_fill_int (ra
, fill
, ignore
)
392 scm_sizet i
, n
= SCM_ARRAY_DIMS (ra
)->ubnd
- SCM_ARRAY_DIMS (ra
)->lbnd
+ 1;
393 long inc
= SCM_ARRAY_DIMS (ra
)->inc
;
394 scm_sizet base
= SCM_ARRAY_BASE (ra
);
395 ra
= SCM_ARRAY_V (ra
);
400 for (i
= base
; n
--; i
+= inc
)
401 scm_array_set_x (ra
, fill
, SCM_MAKINUM (i
));
404 for (i
= base
; n
--; i
+= inc
)
405 SCM_VELTS (ra
)[i
] = fill
;
408 SCM_ASRTGO (SCM_ICHRP (fill
), badarg2
);
409 for (i
= base
; n
--; i
+= inc
)
410 SCM_CHARS (ra
)[i
] = SCM_ICHR (fill
);
414 long *ve
= (long *) SCM_VELTS (ra
);
415 if (1 == inc
&& (n
>= SCM_LONG_BIT
|| n
== SCM_LENGTH (ra
)))
417 i
= base
/ SCM_LONG_BIT
;
418 if (SCM_BOOL_F
== fill
)
420 if (base
% SCM_LONG_BIT
) /* leading partial word */
421 ve
[i
++] &= ~(~0L << (base
% SCM_LONG_BIT
));
422 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
424 if ((base
+ n
) % SCM_LONG_BIT
) /* trailing partial word */
425 ve
[i
] &= (~0L << ((base
+ n
) % SCM_LONG_BIT
));
427 else if (SCM_BOOL_T
== fill
)
429 if (base
% SCM_LONG_BIT
)
430 ve
[i
++] |= ~0L << (base
% SCM_LONG_BIT
);
431 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
433 if ((base
+ n
) % SCM_LONG_BIT
)
434 ve
[i
] |= ~(~0L << ((base
+ n
) % SCM_LONG_BIT
));
437 badarg2
:scm_wta (fill
, (char *) SCM_ARG2
, s_array_fill_x
);
441 if (SCM_BOOL_F
== fill
)
442 for (i
= base
; n
--; i
+= inc
)
443 ve
[i
/ SCM_LONG_BIT
] &= ~(1L << (i
% SCM_LONG_BIT
));
444 else if (SCM_BOOL_T
== fill
)
445 for (i
= base
; n
--; i
+= inc
)
446 ve
[i
/ SCM_LONG_BIT
] |= (1L << (i
% SCM_LONG_BIT
));
453 SCM_ASRTGO (0 <= SCM_INUM (fill
), badarg2
);
455 SCM_ASRTGO (SCM_INUMP (fill
), badarg2
);
457 long f
= SCM_INUM (fill
), *ve
= (long *) SCM_VELTS (ra
);
458 for (i
= base
; n
--; i
+= inc
)
466 float f
, *ve
= (float *) SCM_VELTS (ra
);
467 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_REALP (fill
), badarg2
);
468 f
= SCM_REALPART (fill
);
469 for (i
= base
; n
--; i
+= inc
)
473 #endif /* SCM_SINGLES */
476 double f
, *ve
= (double *) SCM_VELTS (ra
);
477 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_REALP (fill
), badarg2
);
478 f
= SCM_REALPART (fill
);
479 for (i
= base
; n
--; i
+= inc
)
486 double (*ve
)[2] = (double (*)[2]) SCM_VELTS (ra
);
487 SCM_ASRTGO (SCM_NIMP (fill
) && SCM_INEXP (fill
), badarg2
);
488 fr
= SCM_REALPART (fill
);
489 fi
= (SCM_CPLXP (fill
) ? SCM_IMAG (fill
) : 0.0);
490 for (i
= base
; n
--; i
+= inc
)
497 #endif /* SCM_FLOATS */
502 SCM_PROC(s_array_fill_x
, "array-fill!", 2, 0, 0, scm_array_fill_x
);
505 scm_array_fill_x (SCM ra
, SCM fill
)
508 scm_array_fill_x (ra
, fill
)
513 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, s_array_fill_x
);
514 return SCM_UNSPECIFIED
;
521 racp (SCM dst
, SCM src
)
529 long n
= (SCM_ARRAY_DIMS (src
)->ubnd
- SCM_ARRAY_DIMS (src
)->lbnd
+ 1);
530 long inc_d
, inc_s
= SCM_ARRAY_DIMS (src
)->inc
;
531 scm_sizet i_d
, i_s
= SCM_ARRAY_BASE (src
);
533 inc_d
= SCM_ARRAY_DIMS (dst
)->inc
;
534 i_d
= SCM_ARRAY_BASE (dst
);
535 src
= SCM_ARRAY_V (src
);
536 dst
= SCM_ARRAY_V (dst
);
541 gencase
: case scm_tc7_vector
:
542 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
543 scm_array_set_x (dst
, scm_cvref (src
, i_s
, SCM_UNDEFINED
), SCM_MAKINUM (i_d
));
546 if (scm_tc7_string
!= SCM_TYP7 (dst
))
548 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
549 SCM_CHARS (dst
)[i_d
] = SCM_CHARS (src
)[i_s
];
552 if (scm_tc7_bvect
!= SCM_TYP7 (dst
))
554 if (1 == inc_d
&& 1 == inc_s
&& i_s
% SCM_LONG_BIT
== i_d
% SCM_LONG_BIT
&& n
>= SCM_LONG_BIT
)
556 long *sv
= (long *) SCM_VELTS (src
);
557 long *dv
= (long *) SCM_VELTS (dst
);
558 sv
+= i_s
/ SCM_LONG_BIT
;
559 dv
+= i_d
/ SCM_LONG_BIT
;
560 if (i_s
% SCM_LONG_BIT
)
561 { /* leading partial word */
562 *dv
= (*dv
& ~(~0L << (i_s
% SCM_LONG_BIT
))) | (*sv
& (~0L << (i_s
% SCM_LONG_BIT
)));
565 n
-= SCM_LONG_BIT
- (i_s
% SCM_LONG_BIT
);
568 for (; n
>= SCM_LONG_BIT
; n
-= SCM_LONG_BIT
, sv
++, dv
++)
570 if (n
) /* trailing partial word */
571 *dv
= (*dv
& (~0L << n
)) | (*sv
& ~(~0L << n
));
575 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
576 if (SCM_VELTS (src
)[i_s
/ SCM_LONG_BIT
] & (1L << (i_s
% SCM_LONG_BIT
)))
577 SCM_VELTS (dst
)[i_d
/ SCM_LONG_BIT
] |= (1L << (i_d
% SCM_LONG_BIT
));
579 SCM_VELTS (dst
)[i_d
/ SCM_LONG_BIT
] &= ~(1L << (i_d
% SCM_LONG_BIT
));
583 if (scm_tc7_uvect
!= SCM_TYP7 (src
))
587 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
589 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
594 if (scm_tc7_uvect
!= SCM_TYP7 (src
) && scm_tc7_ivect
!= SCM_TYP7 (src
))
598 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
600 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
608 float *d
= (float *) SCM_VELTS (dst
);
609 float *s
= (float *) SCM_VELTS (src
);
618 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
619 d
[i_d
] = ((long *) s
)[i_s
];)
623 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
628 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
629 d
[i_d
] = ((double *) s
)[i_s
];)
634 #endif /* SCM_SINGLES */
637 double *d
= (double *) SCM_VELTS (dst
);
638 double *s
= (double *) SCM_VELTS (src
);
647 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
648 d
[i_d
] = ((long *) s
)[i_s
];)
652 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
653 d
[i_d
] = ((float *) s
)[i_s
];)
657 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
665 double (*d
)[2] = (double (*)[2]) SCM_VELTS (dst
);
666 double (*s
)[2] = (double (*)[2]) SCM_VELTS (src
);
675 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
677 d
[i_d
][0] = ((long *) s
)[i_s
];
684 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
686 d
[i_d
][0] = ((float *) s
)[i_s
];
693 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
695 d
[i_d
][0] = ((double *) s
)[i_s
];
702 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
704 d
[i_d
][0] = s
[i_s
][0];
705 d
[i_d
][1] = s
[i_s
][1];
712 #endif /* SCM_FLOATS */
717 SCM_PROC(s_serial_array_copy_x
, "serial-array-copy!", 2, 0, 0, scm_array_copy_x
);
718 SCM_PROC(s_array_copy_x
, "array-copy!", 2, 0, 0, scm_array_copy_x
);
721 scm_array_copy_x (SCM src
, SCM dst
)
724 scm_array_copy_x (src
, dst
)
729 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), s_array_copy_x
);
730 return SCM_UNSPECIFIED
;
733 /* Functions callable by ARRAY-MAP! */
737 scm_ra_eqp (SCM ra0
, SCM ras
)
740 scm_ra_eqp (ra0
, ras
)
745 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
746 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
747 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
748 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
749 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
750 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
751 ra0
= SCM_ARRAY_V (ra0
);
752 ra1
= SCM_ARRAY_V (ra1
);
753 ra2
= SCM_ARRAY_V (ra2
);
754 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
758 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
759 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
763 (scm_eq_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)))
769 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
772 if (SCM_VELTS (ra1
)[i1
] != SCM_VELTS (ra2
)[i2
])
778 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
781 if (((float *) SCM_VELTS (ra1
))[i1
] != ((float *) SCM_VELTS (ra2
))[i2
])
784 #endif /*SCM_SINGLES*/
786 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
789 if (((double *) SCM_VELTS (ra1
))[i1
] != ((double *) SCM_VELTS (ra2
))[i2
])
793 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
796 if (((double *) SCM_VELTS (ra1
))[2 * i1
] != ((double *) SCM_VELTS (ra2
))[2 * i2
] ||
797 ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1] != ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1])
800 #endif /*SCM_FLOATS*/
805 /* opt 0 means <, nonzero means >= */
808 ra_compare (SCM ra0
, SCM ra1
, SCM ra2
, int opt
)
811 ra_compare (ra0
, ra1
, ra2
, opt
)
818 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
819 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
820 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
821 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
822 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
823 ra0
= SCM_ARRAY_V (ra0
);
824 ra1
= SCM_ARRAY_V (ra1
);
825 ra2
= SCM_ARRAY_V (ra2
);
826 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
830 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
831 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
835 SCM_NFALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))) :
836 SCM_FALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
842 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
847 SCM_VELTS (ra1
)[i1
] < SCM_VELTS (ra2
)[i2
] :
848 SCM_VELTS (ra1
)[i1
] >= SCM_VELTS (ra2
)[i2
])
855 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
859 ((float *) SCM_VELTS (ra1
))[i1
] < ((float *) SCM_VELTS (ra2
))[i2
] :
860 ((float *) SCM_VELTS (ra1
))[i1
] >= ((float *) SCM_VELTS (ra2
))[i2
])
863 #endif /*SCM_SINGLES*/
865 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
869 ((double *) SCM_VELTS (ra1
))[i1
] < ((double *) SCM_VELTS (ra2
))[i2
] :
870 ((double *) SCM_VELTS (ra1
))[i1
] >= ((double *) SCM_VELTS (ra2
))[i2
])
873 #endif /*SCM_FLOATS*/
881 scm_ra_lessp (SCM ra0
, SCM ras
)
884 scm_ra_lessp (ra0
, ras
)
889 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
894 scm_ra_leqp (SCM ra0
, SCM ras
)
897 scm_ra_leqp (ra0
, ras
)
902 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
907 scm_ra_grp (SCM ra0
, SCM ras
)
910 scm_ra_grp (ra0
, ras
)
915 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
920 scm_ra_greqp (SCM ra0
, SCM ras
)
923 scm_ra_greqp (ra0
, ras
)
928 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
934 scm_ra_sum (SCM ra0
, SCM ras
)
937 scm_ra_sum (ra0
, ras
)
942 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
943 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
944 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
945 ra0
= SCM_ARRAY_V (ra0
);
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)
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
)),
966 long *v0
= SCM_VELTS (ra0
);
967 long *v1
= SCM_VELTS (ra1
);
969 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
977 float *v0
= (float *) SCM_VELTS (ra0
);
978 float *v1
= (float *) SCM_VELTS (ra1
);
980 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
984 #endif /* SCM_SINGLES */
987 double *v0
= (double *) SCM_VELTS (ra0
);
988 double *v1
= (double *) SCM_VELTS (ra1
);
990 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
996 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
997 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
999 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1001 v0
[i0
][0] += v1
[i1
][0];
1002 v0
[i0
][1] += v1
[i1
][1];
1007 #endif /* SCM_FLOATS */
1016 scm_ra_difference (SCM ra0
, SCM ras
)
1019 scm_ra_difference (ra0
, ras
)
1024 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1025 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1026 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1027 ra0
= SCM_ARRAY_V (ra0
);
1036 SCM e0
= SCM_UNDEFINED
;
1037 for (; n
-- > 0; i0
+= inc0
)
1038 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1045 float *v0
= (float *) SCM_VELTS (ra0
);
1046 for (; n
-- > 0; i0
+= inc0
)
1050 #endif /* SCM_SINGLES */
1053 double *v0
= (double *) SCM_VELTS (ra0
);
1054 for (; n
-- > 0; i0
+= inc0
)
1060 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1061 for (; n
-- > 0; i0
+= inc0
)
1063 v0
[i0
][0] = -v0
[i0
][0];
1064 v0
[i0
][1] = -v0
[i0
][1];
1068 #endif /* SCM_FLOATS */
1073 SCM ra1
= SCM_CAR (ras
);
1074 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1075 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1076 ra1
= SCM_ARRAY_V (ra1
);
1077 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1081 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1082 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1083 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1090 float *v0
= (float *) SCM_VELTS (ra0
);
1091 float *v1
= (float *) SCM_VELTS (ra1
);
1093 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1097 #endif /* SCM_SINGLES */
1100 double *v0
= (double *) SCM_VELTS (ra0
);
1101 double *v1
= (double *) SCM_VELTS (ra1
);
1103 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1109 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1110 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1112 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1114 v0
[i0
][0] -= v1
[i1
][0];
1115 v0
[i0
][1] -= v1
[i1
][1];
1120 #endif /* SCM_FLOATS */
1129 scm_ra_product (SCM ra0
, SCM ras
)
1132 scm_ra_product (ra0
, ras
)
1137 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1138 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1139 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1140 ra0
= SCM_ARRAY_V (ra0
);
1144 SCM ra1
= SCM_CAR (ras
);
1145 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1146 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1147 ra1
= SCM_ARRAY_V (ra1
);
1148 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1152 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1153 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1154 scm_array_set_x (ra0
, scm_product (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1161 long *v0
= SCM_VELTS (ra0
);
1162 long *v1
= SCM_VELTS (ra1
);
1164 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1172 float *v0
= (float *) SCM_VELTS (ra0
);
1173 float *v1
= (float *) SCM_VELTS (ra1
);
1175 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1179 #endif /* SCM_SINGLES */
1182 double *v0
= (double *) SCM_VELTS (ra0
);
1183 double *v1
= (double *) SCM_VELTS (ra1
);
1185 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1191 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1193 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1195 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1197 r
= v0
[i0
][0] * v1
[i1
][0] - v0
[i0
][1] * v1
[i1
][1];
1198 v0
[i0
][1] = v0
[i0
][0] * v1
[i1
][1] + v0
[i0
][1] * v1
[i1
][0];
1204 #endif /* SCM_FLOATS */
1212 scm_ra_divide (SCM ra0
, SCM ras
)
1215 scm_ra_divide (ra0
, ras
)
1220 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1221 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1222 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1223 ra0
= SCM_ARRAY_V (ra0
);
1232 SCM e0
= SCM_UNDEFINED
;
1233 for (; n
-- > 0; i0
+= inc0
)
1234 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1241 float *v0
= (float *) SCM_VELTS (ra0
);
1242 for (; n
-- > 0; i0
+= inc0
)
1243 v0
[i0
] = 1.0 / v0
[i0
];
1246 #endif /* SCM_SINGLES */
1249 double *v0
= (double *) SCM_VELTS (ra0
);
1250 for (; n
-- > 0; i0
+= inc0
)
1251 v0
[i0
] = 1.0 / v0
[i0
];
1257 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1258 for (; n
-- > 0; i0
+= inc0
)
1260 d
= v0
[i0
][0] * v0
[i0
][0] + v0
[i0
][1] * v0
[i0
][1];
1266 #endif /* SCM_FLOATS */
1271 SCM ra1
= SCM_CAR (ras
);
1272 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1273 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1274 ra1
= SCM_ARRAY_V (ra1
);
1275 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1279 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1280 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1281 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1288 float *v0
= (float *) SCM_VELTS (ra0
);
1289 float *v1
= (float *) SCM_VELTS (ra1
);
1291 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1295 #endif /* SCM_SINGLES */
1298 double *v0
= (double *) SCM_VELTS (ra0
);
1299 double *v1
= (double *) SCM_VELTS (ra1
);
1301 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1307 register double d
, r
;
1308 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1309 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1311 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1313 d
= v1
[i1
][0] * v1
[i1
][0] + v1
[i1
][1] * v1
[i1
][1];
1314 r
= (v0
[i0
][0] * v1
[i1
][0] + v0
[i0
][1] * v1
[i1
][1]) / d
;
1315 v0
[i0
][1] = (v0
[i0
][1] * v1
[i1
][0] - v0
[i0
][0] * v1
[i1
][1]) / d
;
1321 #endif /* SCM_FLOATS */
1329 scm_array_identity (SCM src
, SCM dst
)
1332 scm_array_identity (dst
, src
)
1337 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
1344 ramap (SCM ra0
, SCM proc
, SCM ras
)
1347 ramap (ra0
, proc
, ras
)
1353 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1354 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
1355 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1356 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
1357 ra0
= SCM_ARRAY_V (ra0
);
1361 scm_array_set_x (ra0
, scm_apply (proc
, SCM_EOL
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1364 SCM ra1
= SCM_CAR (ras
);
1365 SCM args
, *ve
= &ras
;
1366 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1367 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1368 ra1
= SCM_ARRAY_V (ra1
);
1369 ras
= SCM_CDR (ras
);
1375 ras
= scm_vector (ras
);
1376 ve
= SCM_VELTS (ras
);
1378 for (; i
<= n
; i
++, i1
+= inc1
)
1381 for (k
= SCM_LENGTH (ras
); k
--;)
1382 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1383 args
= scm_cons (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1384 scm_array_set_x (ra0
, scm_apply (proc
, args
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1392 ramap_cxr (SCM ra0
, SCM proc
, SCM ras
)
1395 ramap_cxr (ra0
, proc
, ras
)
1401 SCM ra1
= SCM_CAR (ras
);
1402 SCM e1
= SCM_UNDEFINED
;
1403 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1404 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1405 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
1406 ra0
= SCM_ARRAY_V (ra0
);
1407 ra1
= SCM_ARRAY_V (ra1
);
1413 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1414 scm_array_set_x (ra0
, scm_apply (proc
, RVREF (ra1
, i1
, e1
), scm_listofnull
), SCM_MAKINUM (i0
));
1420 float *dst
= (float *) SCM_VELTS (ra0
);
1427 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1428 dst
[i0
] = SCM_DSUBRF (proc
) ((double) ((float *) SCM_VELTS (ra1
))[i1
]);
1432 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1433 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1438 #endif /* SCM_SINGLES */
1441 double *dst
= (double *) SCM_VELTS (ra0
);
1448 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1449 dst
[i0
] = SCM_DSUBRF (proc
) (((double *) SCM_VELTS (ra1
))[i1
]);
1453 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1454 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1459 #endif /* SCM_FLOATS */
1467 ramap_rp (SCM ra0
, SCM proc
, SCM ras
)
1470 ramap_rp (ra0
, proc
, ras
)
1476 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
1477 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
1478 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1479 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
1480 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1481 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1482 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
1483 ra0
= SCM_ARRAY_V (ra0
);
1484 ra1
= SCM_ARRAY_V (ra1
);
1485 ra2
= SCM_ARRAY_V (ra2
);
1486 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
1489 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1493 (SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)))
1498 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1503 (SCM_SUBRF (proc
) (SCM_MAKINUM (SCM_VELTS (ra1
)[i1
]),
1504 SCM_MAKINUM (SCM_VELTS (ra2
)[i2
])))
1512 SCM a1
= scm_makflo (1.0), a2
= scm_makflo (1.0);
1513 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1517 SCM_FLO (a1
) = ((float *) SCM_VELTS (ra1
))[i1
];
1518 SCM_FLO (a2
) = ((float *) SCM_VELTS (ra2
))[i2
];
1520 (SCM_SUBRF (proc
) (a1
, a2
))
1525 #endif /*SCM_SINGLES*/
1528 SCM a1
= scm_makdbl (1.0 / 3.0, 0.0), a2
= scm_makdbl (1.0 / 3.0, 0.0);
1529 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1533 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[i1
];
1534 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[i2
];
1536 (SCM_SUBRF (proc
) (a1
, a2
))
1543 SCM a1
= scm_makdbl (1.0, 1.0), a2
= scm_makdbl (1.0, 1.0);
1544 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1548 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
];
1549 SCM_IMAG (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1];
1550 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
];
1551 SCM_IMAG (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1];
1553 (SCM_SUBRF (proc
) (a1
, a2
))
1558 #endif /*SCM_FLOATS*/
1566 ramap_1 (SCM ra0
, SCM proc
, SCM ras
)
1569 ramap_1 (ra0
, proc
, ras
)
1575 SCM ra1
= SCM_CAR (ras
);
1576 SCM e1
= SCM_UNDEFINED
;
1577 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1578 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1579 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1580 ra0
= SCM_ARRAY_V (ra0
);
1581 ra1
= SCM_ARRAY_V (ra1
);
1582 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1583 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1584 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
)), SCM_MAKINUM (i0
));
1586 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1587 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1594 ramap_2o (SCM ra0
, SCM proc
, SCM ras
)
1597 ramap_2o (ra0
, proc
, ras
)
1603 SCM ra1
= SCM_CAR (ras
);
1604 SCM e1
= SCM_UNDEFINED
;
1605 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1606 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1607 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1608 ra0
= SCM_ARRAY_V (ra0
);
1609 ra1
= SCM_ARRAY_V (ra1
);
1610 ras
= SCM_CDR (ras
);
1614 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1615 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1616 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), SCM_UNDEFINED
),
1619 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1620 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), SCM_UNDEFINED
),
1625 SCM ra2
= SCM_CAR (ras
);
1626 SCM e2
= SCM_UNDEFINED
;
1627 scm_sizet i2
= SCM_ARRAY_BASE (ra2
);
1628 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
1629 ra2
= SCM_ARRAY_V (ra2
);
1630 if (scm_tc7_vector
== SCM_TYP7 (ra0
))
1631 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1632 scm_array_set_x (ra0
,
1633 SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), scm_cvref (ra2
, i2
, SCM_UNDEFINED
)),
1636 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1637 scm_array_set_x (ra0
,
1638 SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)),
1647 ramap_a (SCM ra0
, SCM proc
, SCM ras
)
1650 ramap_a (ra0
, proc
, ras
)
1656 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1657 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1658 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1659 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1660 ra0
= SCM_ARRAY_V (ra0
);
1663 for (; n
-- > 0; i0
+= inc0
)
1664 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1667 SCM ra1
= SCM_CAR (ras
);
1668 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1669 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1670 ra1
= SCM_ARRAY_V (ra1
);
1671 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1672 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1678 SCM_PROC(s_serial_array_map
, "serial-array-map", 2, 0, 1, scm_array_map
);
1679 SCM_PROC(s_array_map
, "array-map", 2, 0, 1, scm_array_map
);
1682 scm_array_map (SCM ra0
, SCM proc
, SCM lra
)
1685 scm_array_map (ra0
, proc
, lra
)
1691 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG2
, s_array_map
);
1692 switch (SCM_TYP7 (proc
))
1696 scm_ramapc (ramap
, proc
, ra0
, lra
, s_array_map
);
1697 return SCM_UNSPECIFIED
;
1698 case scm_tc7_subr_1
:
1699 scm_ramapc (ramap_1
, proc
, ra0
, lra
, s_array_map
);
1700 return SCM_UNSPECIFIED
;
1701 case scm_tc7_subr_2
:
1702 case scm_tc7_subr_2o
:
1703 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, s_array_map
);
1704 return SCM_UNSPECIFIED
;
1706 if (!SCM_SUBRF (proc
))
1708 scm_ramapc (ramap_cxr
, proc
, ra0
, lra
, s_array_map
);
1709 return SCM_UNSPECIFIED
;
1710 case scm_tc7_rpsubr
:
1713 if (SCM_FALSEP (scm_array_p (ra0
, SCM_BOOL_T
)))
1715 scm_array_fill_x (ra0
, SCM_BOOL_T
);
1716 for (p
= ra_rpsubrs
; p
->name
; p
++)
1717 if (proc
== p
->sproc
)
1719 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1721 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, s_array_map
);
1722 lra
= SCM_CDR (lra
);
1724 return SCM_UNSPECIFIED
;
1726 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1728 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, s_array_map
);
1729 lra
= SCM_CDR (lra
);
1731 return SCM_UNSPECIFIED
;
1737 SCM prot
, fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
1741 prot
= scm_array_prototype (ra0
);
1742 if (SCM_NIMP (prot
) && SCM_INEXP (prot
))
1743 fill
= scm_makdbl ((double) SCM_INUM (fill
), 0.0);
1746 scm_array_fill_x (ra0
, fill
);
1750 SCM tail
, ra1
= SCM_CAR (lra
);
1751 SCM v0
= (SCM_NIMP (ra0
) && SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
1753 /* Check to see if order might matter.
1754 This might be an argument for a separate
1755 SERIAL-ARRAY-MAP! */
1756 if (v0
== ra1
|| (SCM_NIMP (ra1
) && SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1757 if (ra0
!= ra1
|| (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
1759 for (tail
= SCM_CDR (lra
); SCM_NNULLP (tail
); tail
= SCM_CDR (tail
))
1761 ra1
= SCM_CAR (tail
);
1762 if (v0
== ra1
|| (SCM_NIMP (ra1
) && SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1765 for (p
= ra_asubrs
; p
->name
; p
++)
1766 if (proc
== p
->sproc
)
1768 if (ra0
!= SCM_CAR (lra
))
1769 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), s_array_map
);
1770 lra
= SCM_CDR (lra
);
1773 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, s_array_map
);
1774 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
1775 return SCM_UNSPECIFIED
;
1776 lra
= SCM_CDR (lra
);
1779 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, s_array_map
);
1780 lra
= SCM_CDR (lra
);
1783 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
1784 scm_ramapc (ramap_a
, proc
, ra0
, lra
, s_array_map
);
1786 return SCM_UNSPECIFIED
;
1792 rafe (SCM ra0
, SCM proc
, SCM ras
)
1795 rafe (ra0
, proc
, ras
)
1801 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1802 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1803 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1804 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1805 ra0
= SCM_ARRAY_V (ra0
);
1808 for (; i
<= n
; i
++, i0
+= inc0
)
1809 scm_apply (proc
, scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_listofnull
);
1812 SCM ra1
= SCM_CAR (ras
);
1813 SCM args
, *ve
= &ras
;
1814 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1815 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1816 ra1
= SCM_ARRAY_V (ra1
);
1817 ras
= SCM_CDR (ras
);
1823 ras
= scm_vector (ras
);
1824 ve
= SCM_VELTS (ras
);
1826 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
1829 for (k
= SCM_LENGTH (ras
); k
--;)
1830 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1831 args
= scm_cons2 (scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1832 scm_apply (proc
, args
, SCM_EOL
);
1839 SCM_PROC(s_array_for_each
, "array-for-each", 2, 0, 1, scm_array_for_each
);
1842 scm_array_for_each (SCM proc
, SCM ra0
, SCM lra
)
1845 scm_array_for_each (proc
, ra0
, lra
)
1851 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG1
, s_array_for_each
);
1852 scm_ramapc (rafe
, proc
, ra0
, lra
, s_array_for_each
);
1853 return SCM_UNSPECIFIED
;
1856 SCM_PROC(s_array_index_map_x
, "array-index-map!", 2, 0, 0, scm_array_index_map_x
);
1859 scm_array_index_map_x (SCM ra
, SCM proc
)
1862 scm_array_index_map_x (ra
, proc
)
1868 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, s_array_index_map_x
);
1869 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
), proc
, SCM_ARG2
, s_array_index_map_x
);
1874 badarg
:scm_wta (ra
, (char *) SCM_ARG1
, s_array_index_map_x
);
1875 case scm_tc7_vector
:
1877 SCM
*ve
= SCM_VELTS (ra
);
1878 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1879 ve
[i
] = scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
);
1880 return SCM_UNSPECIFIED
;
1882 case scm_tc7_string
:
1889 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1890 scm_array_set_x (ra
, scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
), SCM_MAKINUM (i
));
1891 return SCM_UNSPECIFIED
;
1893 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
1896 SCM inds
= scm_make_uve (SCM_ARRAY_NDIM (ra
), SCM_MAKINUM (-1L));
1897 long *vinds
= SCM_VELTS (inds
);
1898 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
1899 for (k
= 0; k
<= kmax
; k
++)
1900 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1906 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1907 i
= cind (ra
, inds
);
1908 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1910 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1911 args
= scm_cons (SCM_MAKINUM (vinds
[j
]), args
);
1912 scm_array_set_x (SCM_ARRAY_V (ra
), scm_apply (proc
, args
, SCM_EOL
), SCM_MAKINUM (i
));
1913 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1918 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1924 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1928 return SCM_UNSPECIFIED
;
1935 raeql_1 (SCM ra0
, SCM as_equal
, SCM ra1
)
1938 raeql_1 (ra0
, as_equal
, ra1
)
1944 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1945 scm_sizet i0
= 0, i1
= 0;
1946 long inc0
= 1, inc1
= 1;
1947 scm_sizet n
= SCM_LENGTH (ra0
);
1948 ra1
= SCM_CAR (ra1
);
1952 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1953 i0
= SCM_ARRAY_BASE (ra0
);
1954 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1955 ra0
= SCM_ARRAY_V (ra0
);
1960 i1
= SCM_ARRAY_BASE (ra1
);
1961 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1962 ra1
= SCM_ARRAY_V (ra1
);
1967 case scm_tc7_vector
:
1969 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1975 (scm_array_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)))
1979 (scm_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)))
1983 case scm_tc7_string
:
1985 char *v0
= SCM_CHARS (ra0
) + i0
;
1986 char *v1
= SCM_CHARS (ra1
) + i1
;
1987 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1993 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1994 if (BVE_REF (ra0
, i0
) != BVE_REF (ra1
, i1
))
2000 long *v0
= (long *) SCM_VELTS (ra0
) + i0
;
2001 long *v1
= (long *) SCM_VELTS (ra1
) + i1
;
2002 for (; n
--; v0
+= inc0
, v1
+= inc1
)
2011 float *v0
= (float *) SCM_VELTS (ra0
) + i0
;
2012 float *v1
= (float *) SCM_VELTS (ra1
) + i1
;
2013 for (; n
--; v0
+= inc0
, v1
+= inc1
)
2018 #endif /* SCM_SINGLES */
2021 double *v0
= (double *) SCM_VELTS (ra0
) + i0
;
2022 double *v1
= (double *) SCM_VELTS (ra1
) + i1
;
2023 for (; n
--; v0
+= inc0
, v1
+= inc1
)
2030 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
) + i0
;
2031 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
) + i1
;
2032 for (; n
--; v0
+= inc0
, v1
+= inc1
)
2034 if ((*v0
)[0] != (*v1
)[0])
2036 if ((*v0
)[1] != (*v1
)[1])
2041 #endif /* SCM_FLOATS */
2048 raeql (SCM ra0
, SCM as_equal
, SCM ra1
)
2051 raeql (ra0
, as_equal
, ra1
)
2057 SCM v0
= ra0
, v1
= ra1
;
2058 scm_array_dim dim0
, dim1
;
2059 scm_array_dim
*s0
= &dim0
, *s1
= &dim1
;
2060 scm_sizet bas0
= 0, bas1
= 0;
2061 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
2065 ndim
= SCM_ARRAY_NDIM (ra0
);
2066 s0
= SCM_ARRAY_DIMS (ra0
);
2067 bas0
= SCM_ARRAY_BASE (ra0
);
2068 v0
= SCM_ARRAY_V (ra0
);
2074 s0
->ubnd
= SCM_LENGTH (v0
) - 1;
2080 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
2082 s1
= SCM_ARRAY_DIMS (ra1
);
2083 bas1
= SCM_ARRAY_BASE (ra1
);
2084 v1
= SCM_ARRAY_V (ra1
);
2092 s1
->ubnd
= SCM_LENGTH (v1
) - 1;
2095 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
2097 for (k
= ndim
; k
--;)
2099 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
2103 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
2104 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
2107 if (unroll
&& bas0
== bas1
&& v0
== v1
)
2109 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
2114 scm_raequal (SCM ra0
, SCM ra1
)
2117 scm_raequal (ra0
, ra1
)
2122 return (raeql (ra0
, SCM_BOOL_T
, ra1
) ? SCM_BOOL_T
: SCM_BOOL_F
);
2125 static char s_array_equal_p
[] = "array-equal?";
2129 scm_array_equal_p (SCM ra0
, SCM ra1
)
2132 scm_array_equal_p (ra0
, ra1
)
2137 if (SCM_IMP (ra0
) || SCM_IMP (ra1
))
2138 callequal
:return scm_equal_p (ra0
, ra1
);
2145 case scm_tc7_string
:
2151 case scm_tc7_vector
:
2154 if (!SCM_ARRAYP (ra0
))
2163 case scm_tc7_string
:
2169 case scm_tc7_vector
:
2172 if (!SCM_ARRAYP (ra1
))
2175 return (raeql (ra0
, SCM_BOOL_F
, ra1
) ? SCM_BOOL_T
: SCM_BOOL_F
);
2181 /* These tables are a kluge that will not scale well when more
2182 * vectorized subrs are added. It is tempting to steal some bits from
2183 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
2184 * offset into a table of vectorized subrs.
2187 static ra_iproc ra_rpsubrs
[] =
2189 {"=", SCM_UNDEFINED
, scm_ra_eqp
},
2190 {"<", SCM_UNDEFINED
, scm_ra_lessp
},
2191 {"<=", SCM_UNDEFINED
, scm_ra_leqp
},
2192 {">", SCM_UNDEFINED
, scm_ra_grp
},
2193 {">=", SCM_UNDEFINED
, scm_ra_greqp
},
2197 static ra_iproc ra_asubrs
[] =
2199 {"+", SCM_UNDEFINED
, scm_ra_sum
},
2200 {"-", SCM_UNDEFINED
, scm_ra_difference
},
2201 {"*", SCM_UNDEFINED
, scm_ra_product
},
2202 {"/", SCM_UNDEFINED
, scm_ra_divide
},
2206 static void init_raprocs (subra
)
2209 for (; subra
->name
; subra
++)
2210 subra
->sproc
= SCM_CDR (scm_intern (subra
->name
, strlen (subra
->name
)));
2215 scm_init_ramap (void)
2221 init_raprocs (ra_rpsubrs
);
2222 init_raprocs (ra_asubrs
);
2223 scm_make_subr (s_array_equal_p
, scm_tc7_rpsubr
, scm_array_equal_p
);
2224 scm_smobs
[0x0ff & (scm_tc16_array
>> 8)].equalp
= scm_raequal
;
2226 scm_add_feature (s_array_for_each
);