1 /* Copyright (C) 1996, 1998 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, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
59 #include "scm_validate.h"
63 #define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0)
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.
79 static ra_iproc ra_rpsubrs
[] =
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
},
89 static ra_iproc ra_asubrs
[] =
91 {"+", SCM_UNDEFINED
, scm_ra_sum
},
92 {"-", SCM_UNDEFINED
, scm_ra_difference
},
93 {"*", SCM_UNDEFINED
, scm_ra_product
},
94 {"/", SCM_UNDEFINED
, scm_ra_divide
},
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)))
103 /* Fast, recycling scm_vector ref */
104 #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
106 /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
108 /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
109 elements of scm_vector operands are not aliased */
111 #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
113 #define IVDEP(test, line) line
118 /* inds must be a uvect or ivect, no check. */
122 cind (SCM ra
, SCM inds
)
126 long *ve
= SCM_VELTS (inds
);
127 if (!SCM_ARRAYP (ra
))
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
;
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;
145 scm_ra_matchp (SCM ra0
, SCM ras
)
149 scm_array_dim
*s0
= &dims
;
153 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
154 if (SCM_IMP (ra0
)) return 0;
155 switch (SCM_TYP7 (ra0
))
167 #ifdef HAVE_LONG_LONGS
175 s0
->ubnd
= (long) SCM_LENGTH (ra0
) - 1;
178 if (!SCM_ARRAYP (ra0
))
180 ndim
= SCM_ARRAY_NDIM (ra0
);
181 s0
= SCM_ARRAY_DIMS (ra0
);
182 bas0
= SCM_ARRAY_BASE (ra0
);
185 while (SCM_NIMP (ras
))
203 #ifdef HAVE_LONG_LONGS
220 if ((0 == s0
->lbnd
) && (s0
->ubnd
== SCM_LENGTH (ra1
) - 1))
224 if (s0
->lbnd
< 0 || s0
->ubnd
>= SCM_LENGTH (ra1
))
229 if (!SCM_ARRAYP (ra1
) || ndim
!= SCM_ARRAY_NDIM (ra1
))
231 s1
= SCM_ARRAY_DIMS (ra1
);
232 if (bas0
!= SCM_ARRAY_BASE (ra1
))
234 for (i
= 0; i
< ndim
; i
++)
239 if (s0
[i
].inc
!= s1
[i
].inc
)
242 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
246 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
247 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
256 /* array mapper: apply cproc to each dimension of the given arrays?.
257 int (*cproc) (); procedure to call on unrolled arrays?
258 cproc (dest, source list) or
259 cproc (dest, data, source list).
260 SCM data; data to give to cproc or unbound.
261 SCM ra0; destination array.
262 SCM lra; list of source arrays.
263 const char *what; caller, for error reporting. */
265 scm_ramapc (int (*cproc
)(), SCM data
, SCM ra0
, SCM lra
, const char *what
)
272 switch (scm_ra_matchp (ra0
, lra
))
276 scm_wta (ra0
, "array shape mismatch", what
);
279 case 4: /* Try unrolling arrays */
280 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
283 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
284 if (SCM_IMP (vra0
)) goto gencase
;
285 if (!SCM_ARRAYP (vra0
))
287 vra1
= scm_make_ra (1);
288 SCM_ARRAY_BASE (vra1
) = 0;
289 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
290 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_LENGTH (vra0
) - 1;
291 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
292 SCM_ARRAY_V (vra1
) = vra0
;
297 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
300 vra1
= scm_make_ra (1);
301 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
302 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
303 if (!SCM_ARRAYP (ra1
))
305 SCM_ARRAY_BASE (vra1
) = 0;
306 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
307 SCM_ARRAY_V (vra1
) = ra1
;
309 else if (!SCM_ARRAY_CONTP (ra1
))
313 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
314 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
315 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
317 *plvra
= scm_cons (vra1
, SCM_EOL
);
318 plvra
= SCM_CDRLOC (*plvra
);
320 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
322 gencase
: /* Have to loop over all dimensions. */
323 vra0
= scm_make_ra (1);
324 if (SCM_ARRAYP (ra0
))
326 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
329 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
330 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
331 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
335 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
336 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
337 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
339 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
340 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
345 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
346 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_LENGTH (ra0
) - 1;
347 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
348 SCM_ARRAY_BASE (vra0
) = 0;
349 SCM_ARRAY_V (vra0
) = ra0
;
354 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
357 vra1
= scm_make_ra (1);
358 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
359 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
360 if (SCM_ARRAYP (ra1
))
363 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
364 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
368 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
369 SCM_ARRAY_V (vra1
) = ra1
;
371 *plvra
= scm_cons (vra1
, SCM_EOL
);
372 plvra
= SCM_CDRLOC (*plvra
);
374 inds
= scm_make_uve (SCM_ARRAY_NDIM (ra0
), SCM_MAKINUM (-1L));
375 vinds
= (long *) SCM_VELTS (inds
);
376 for (k
= 0; k
<= kmax
; k
++)
377 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
384 SCM_ARRAY_BASE (vra0
) = cind (ra0
, inds
);
385 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
386 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), inds
);
387 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
392 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
398 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
407 SCM_DEFINE(scm_array_fill_x
, "array-fill!", 2, 0, 0,
409 "Stores @var{fill} in every element of @var{array}. The value returned
411 #define FUNC_NAME s_scm_array_fill_x
413 SCM_RAMAPC (scm_array_fill_int
, fill
, ra
, SCM_EOL
);
414 return SCM_UNSPECIFIED
;
418 /* to be used as cproc in scm_ramapc to fill an array dimension with
421 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore
)
422 #define FUNC_NAME s_scm_array_fill_x
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
);
429 ra
= SCM_ARRAY_V (ra
);
433 for (i
= base
; n
--; i
+= inc
)
434 scm_array_set_x (ra
, fill
, SCM_MAKINUM (i
));
438 for (i
= base
; n
--; i
+= inc
)
439 SCM_VELTS (ra
)[i
] = fill
;
442 SCM_ASRTGO (SCM_ICHRP (fill
), badarg2
);
443 for (i
= base
; n
--; i
+= inc
)
444 SCM_CHARS (ra
)[i
] = SCM_ICHR (fill
);
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,
452 for (i
= base
; n
--; i
+= inc
)
453 SCM_CHARS (ra
)[i
] = SCM_INUM (fill
);
457 long *ve
= (long *) SCM_VELTS (ra
);
458 if (1 == inc
&& (n
>= SCM_LONG_BIT
|| n
== SCM_LENGTH (ra
)))
460 i
= base
/ SCM_LONG_BIT
;
461 if (SCM_BOOL_F
== fill
)
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
++)
467 if ((base
+ n
) % SCM_LONG_BIT
) /* trailing partial word */
468 ve
[i
] &= (~0L << ((base
+ n
) % SCM_LONG_BIT
));
470 else if (SCM_BOOL_T
== fill
)
472 if (base
% SCM_LONG_BIT
)
473 ve
[i
++] |= ~0L << (base
% SCM_LONG_BIT
);
474 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
476 if ((base
+ n
) % SCM_LONG_BIT
)
477 ve
[i
] |= ~(~0L << ((base
+ n
) % SCM_LONG_BIT
));
480 badarg2
:SCM_WTA (2,fill
);
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
));
497 unsigned long f
= SCM_NUM2ULONG (2,fill
);
498 unsigned long *ve
= (long *) SCM_VELTS (ra
);
500 for (i
= base
; n
--; i
+= inc
)
506 long f
= SCM_NUM2LONG (2,fill
);
507 long *ve
= (long *) SCM_VELTS (ra
);
509 for (i
= base
; n
--; i
+= inc
)
514 SCM_ASRTGO (SCM_INUMP (fill
), badarg2
);
516 short f
= SCM_INUM (fill
);
517 short *ve
= (short *) SCM_VELTS (ra
);
519 if (f
!= SCM_INUM (fill
))
520 SCM_OUT_OF_RANGE (2, fill
);
521 for (i
= base
; n
--; i
+= inc
)
525 #ifdef HAVE_LONG_LONGS
528 long long f
= SCM_NUM2LONG_LONG (2,fill
);
529 long long *ve
= (long long *) SCM_VELTS (ra
);
531 for (i
= base
; n
--; i
+= inc
)
540 float f
, *ve
= (float *) SCM_VELTS (ra
);
541 SCM_ASRTGO (SCM_REALP (fill
), badarg2
);
542 f
= SCM_REALPART (fill
);
543 for (i
= base
; n
--; i
+= inc
)
547 #endif /* SCM_SINGLES */
550 double f
, *ve
= (double *) SCM_VELTS (ra
);
551 SCM_ASRTGO (SCM_REALP (fill
), badarg2
);
552 f
= SCM_REALPART (fill
);
553 for (i
= base
; n
--; i
+= inc
)
560 double (*ve
)[2] = (double (*)[2]) SCM_VELTS (ra
);
561 SCM_ASRTGO (SCM_INEXP (fill
), badarg2
);
562 fr
= SCM_REALPART (fill
);
563 fi
= (SCM_CPLXP (fill
) ? SCM_IMAG (fill
) : 0.0);
564 for (i
= base
; n
--; i
+= inc
)
571 #endif /* SCM_FLOATS */
579 racp (SCM src
, SCM dst
)
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
);
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
);
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
));
602 if (scm_tc7_string
!= SCM_TYP7 (dst
))
604 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
605 SCM_CHARS (dst
)[i_d
] = SCM_CHARS (src
)[i_s
];
608 if (scm_tc7_bvect
!= SCM_TYP7 (dst
))
610 if (1 == inc_d
&& 1 == inc_s
&& i_s
% SCM_LONG_BIT
== i_d
% SCM_LONG_BIT
&& n
>= SCM_LONG_BIT
)
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
)));
621 n
-= SCM_LONG_BIT
- (i_s
% SCM_LONG_BIT
);
624 for (; n
>= SCM_LONG_BIT
; n
-= SCM_LONG_BIT
, sv
++, dv
++)
626 if (n
) /* trailing partial word */
627 *dv
= (*dv
& (~0L << n
)) | (*sv
& ~(~0L << n
));
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
));
635 SCM_VELTS (dst
)[i_d
/ SCM_LONG_BIT
] &= ~(1L << (i_d
% SCM_LONG_BIT
));
639 if (scm_tc7_uvect
!= SCM_TYP7 (src
))
643 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
645 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
650 if (scm_tc7_uvect
!= SCM_TYP7 (src
) && scm_tc7_ivect
!= SCM_TYP7 (src
))
654 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
656 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
664 float *d
= (float *) SCM_VELTS (dst
);
665 float *s
= (float *) SCM_VELTS (src
);
674 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
675 d
[i_d
] = ((long *) s
)[i_s
];)
679 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
684 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
685 d
[i_d
] = ((double *) s
)[i_s
];)
690 #endif /* SCM_SINGLES */
693 double *d
= (double *) SCM_VELTS (dst
);
694 double *s
= (double *) SCM_VELTS (src
);
703 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
704 d
[i_d
] = ((long *) s
)[i_s
];)
708 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
709 d
[i_d
] = ((float *) s
)[i_s
];)
713 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
721 double (*d
)[2] = (double (*)[2]) SCM_VELTS (dst
);
722 double (*s
)[2] = (double (*)[2]) SCM_VELTS (src
);
731 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
733 d
[i_d
][0] = ((long *) s
)[i_s
];
740 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
742 d
[i_d
][0] = ((float *) s
)[i_s
];
749 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
751 d
[i_d
][0] = ((double *) s
)[i_s
];
758 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
760 d
[i_d
][0] = s
[i_s
][0];
761 d
[i_d
][1] = s
[i_s
][1];
768 #endif /* SCM_FLOATS */
773 /* This name is obsolete. Will go away in release 1.5. */
774 SCM_REGISTER_PROC(s_serial_array_copy_x
, "serial-array-copy!", 2, 0, 0, scm_array_copy_x
);
775 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
778 SCM_DEFINE(scm_array_copy_x
, "array-copy!", 2, 0, 0,
780 "Copies every element from vector or array @var{source} to the
781 corresponding element of @var{destination}. @var{destination} must have
782 the same rank as @var{source}, and be at least as large in each
783 dimension. The order is unspecified.")
784 #define FUNC_NAME s_scm_array_copy_x
786 SCM_RAMAPC (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
));
787 return SCM_UNSPECIFIED
;
791 /* Functions callable by ARRAY-MAP! */
795 scm_ra_eqp (SCM ra0
, SCM ras
)
797 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
798 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
799 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
800 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
801 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
802 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
803 ra0
= SCM_ARRAY_V (ra0
);
804 ra1
= SCM_ARRAY_V (ra1
);
805 ra2
= SCM_ARRAY_V (ra2
);
806 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
810 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
811 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
812 if (BVE_REF (ra0
, i0
))
813 if (SCM_FALSEP(scm_eq_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
819 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
820 if (BVE_REF (ra0
, i0
))
821 if (SCM_VELTS (ra1
)[i1
] != SCM_VELTS (ra2
)[i2
])
827 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
828 if (BVE_REF (ra0
, i0
))
829 if (((float *) SCM_VELTS (ra1
))[i1
] != ((float *) SCM_VELTS (ra2
))[i2
])
832 #endif /*SCM_SINGLES*/
834 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
835 if (BVE_REF (ra0
, i0
))
836 if (((double *) SCM_VELTS (ra1
))[i1
] != ((double *) SCM_VELTS (ra2
))[i2
])
840 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
841 if (BVE_REF (ra0
, i0
))
842 if (((double *) SCM_VELTS (ra1
))[2 * i1
] != ((double *) SCM_VELTS (ra2
))[2 * i2
] ||
843 ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1] != ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1])
846 #endif /*SCM_FLOATS*/
851 /* opt 0 means <, nonzero means >= */
854 ra_compare (SCM ra0
,SCM ra1
,SCM ra2
,int opt
)
856 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
857 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
858 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
859 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
860 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
861 ra0
= SCM_ARRAY_V (ra0
);
862 ra1
= SCM_ARRAY_V (ra1
);
863 ra2
= SCM_ARRAY_V (ra2
);
864 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
868 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
869 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
870 if (BVE_REF (ra0
, i0
))
872 SCM_NFALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))) :
873 SCM_FALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
879 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
881 if (BVE_REF (ra0
, i0
))
883 SCM_VELTS (ra1
)[i1
] < SCM_VELTS (ra2
)[i2
] :
884 SCM_VELTS (ra1
)[i1
] >= SCM_VELTS (ra2
)[i2
])
891 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
892 if (BVE_REF(ra0
, i0
))
894 ((float *) SCM_VELTS (ra1
))[i1
] < ((float *) SCM_VELTS (ra2
))[i2
] :
895 ((float *) SCM_VELTS (ra1
))[i1
] >= ((float *) SCM_VELTS (ra2
))[i2
])
898 #endif /*SCM_SINGLES*/
900 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
901 if (BVE_REF (ra0
, i0
))
903 ((double *) SCM_VELTS (ra1
))[i1
] < ((double *) SCM_VELTS (ra2
))[i2
] :
904 ((double *) SCM_VELTS (ra1
))[i1
] >= ((double *) SCM_VELTS (ra2
))[i2
])
907 #endif /*SCM_FLOATS*/
915 scm_ra_lessp (SCM ra0
, SCM ras
)
917 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
922 scm_ra_leqp (SCM ra0
, SCM ras
)
924 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
929 scm_ra_grp (SCM ra0
, SCM ras
)
931 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
936 scm_ra_greqp (SCM ra0
, SCM ras
)
938 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
943 scm_ra_sum (SCM ra0
, SCM ras
)
945 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
946 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
947 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
948 ra0
= SCM_ARRAY_V (ra0
);
951 SCM ra1
= SCM_CAR (ras
);
952 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
953 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
954 ra1
= SCM_ARRAY_V (ra1
);
955 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
959 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
960 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
961 scm_array_set_x (ra0
, scm_sum (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
968 long *v0
= SCM_VELTS (ra0
);
969 long *v1
= SCM_VELTS (ra1
);
971 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
979 float *v0
= (float *) SCM_VELTS (ra0
);
980 float *v1
= (float *) SCM_VELTS (ra1
);
982 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
986 #endif /* SCM_SINGLES */
989 double *v0
= (double *) SCM_VELTS (ra0
);
990 double *v1
= (double *) SCM_VELTS (ra1
);
992 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
998 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
999 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1001 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1003 v0
[i0
][0] += v1
[i1
][0];
1004 v0
[i0
][1] += v1
[i1
][1];
1009 #endif /* SCM_FLOATS */
1018 scm_ra_difference (SCM ra0
, SCM ras
)
1020 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1021 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1022 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1023 ra0
= SCM_ARRAY_V (ra0
);
1024 if (SCM_NULLP (ras
))
1026 switch (SCM_TYP7 (ra0
))
1030 SCM e0
= SCM_UNDEFINED
;
1031 for (; n
-- > 0; i0
+= inc0
)
1032 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1039 float *v0
= (float *) SCM_VELTS (ra0
);
1040 for (; n
-- > 0; i0
+= inc0
)
1044 #endif /* SCM_SINGLES */
1047 double *v0
= (double *) SCM_VELTS (ra0
);
1048 for (; n
-- > 0; i0
+= inc0
)
1054 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1055 for (; n
-- > 0; i0
+= inc0
)
1057 v0
[i0
][0] = -v0
[i0
][0];
1058 v0
[i0
][1] = -v0
[i0
][1];
1062 #endif /* SCM_FLOATS */
1067 SCM ra1
= SCM_CAR (ras
);
1068 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1069 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1070 ra1
= SCM_ARRAY_V (ra1
);
1071 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1075 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1076 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1077 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1084 float *v0
= (float *) SCM_VELTS (ra0
);
1085 float *v1
= (float *) SCM_VELTS (ra1
);
1087 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1091 #endif /* SCM_SINGLES */
1094 double *v0
= (double *) SCM_VELTS (ra0
);
1095 double *v1
= (double *) SCM_VELTS (ra1
);
1097 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1103 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1104 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1106 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1108 v0
[i0
][0] -= v1
[i1
][0];
1109 v0
[i0
][1] -= v1
[i1
][1];
1114 #endif /* SCM_FLOATS */
1123 scm_ra_product (SCM ra0
, SCM ras
)
1125 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1126 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1127 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1128 ra0
= SCM_ARRAY_V (ra0
);
1129 if (SCM_NNULLP (ras
))
1131 SCM ra1
= SCM_CAR (ras
);
1132 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1133 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1134 ra1
= SCM_ARRAY_V (ra1
);
1135 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1139 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1140 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1141 scm_array_set_x (ra0
, scm_product (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1148 long *v0
= SCM_VELTS (ra0
);
1149 long *v1
= SCM_VELTS (ra1
);
1151 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1159 float *v0
= (float *) SCM_VELTS (ra0
);
1160 float *v1
= (float *) SCM_VELTS (ra1
);
1162 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1166 #endif /* SCM_SINGLES */
1169 double *v0
= (double *) SCM_VELTS (ra0
);
1170 double *v1
= (double *) SCM_VELTS (ra1
);
1172 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1178 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1180 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1182 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1184 r
= v0
[i0
][0] * v1
[i1
][0] - v0
[i0
][1] * v1
[i1
][1];
1185 v0
[i0
][1] = v0
[i0
][0] * v1
[i1
][1] + v0
[i0
][1] * v1
[i1
][0];
1191 #endif /* SCM_FLOATS */
1199 scm_ra_divide (SCM ra0
, SCM ras
)
1201 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1202 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1203 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1204 ra0
= SCM_ARRAY_V (ra0
);
1205 if (SCM_NULLP (ras
))
1207 switch (SCM_TYP7 (ra0
))
1211 SCM e0
= SCM_UNDEFINED
;
1212 for (; n
-- > 0; i0
+= inc0
)
1213 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1220 float *v0
= (float *) SCM_VELTS (ra0
);
1221 for (; n
-- > 0; i0
+= inc0
)
1222 v0
[i0
] = 1.0 / v0
[i0
];
1225 #endif /* SCM_SINGLES */
1228 double *v0
= (double *) SCM_VELTS (ra0
);
1229 for (; n
-- > 0; i0
+= inc0
)
1230 v0
[i0
] = 1.0 / v0
[i0
];
1236 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1237 for (; n
-- > 0; i0
+= inc0
)
1239 d
= v0
[i0
][0] * v0
[i0
][0] + v0
[i0
][1] * v0
[i0
][1];
1245 #endif /* SCM_FLOATS */
1250 SCM ra1
= SCM_CAR (ras
);
1251 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1252 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1253 ra1
= SCM_ARRAY_V (ra1
);
1254 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1258 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1259 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1260 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1267 float *v0
= (float *) SCM_VELTS (ra0
);
1268 float *v1
= (float *) SCM_VELTS (ra1
);
1270 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1274 #endif /* SCM_SINGLES */
1277 double *v0
= (double *) SCM_VELTS (ra0
);
1278 double *v1
= (double *) SCM_VELTS (ra1
);
1280 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1286 register double d
, r
;
1287 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1288 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1290 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1292 d
= v1
[i1
][0] * v1
[i1
][0] + v1
[i1
][1] * v1
[i1
][1];
1293 r
= (v0
[i0
][0] * v1
[i1
][0] + v0
[i0
][1] * v1
[i1
][1]) / d
;
1294 v0
[i0
][1] = (v0
[i0
][1] * v1
[i1
][0] - v0
[i0
][0] * v1
[i1
][1]) / d
;
1300 #endif /* SCM_FLOATS */
1308 scm_array_identity (SCM dst
, SCM src
)
1310 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
1316 ramap (SCM ra0
,SCM proc
,SCM ras
)
1318 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1319 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
1320 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1321 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
1322 ra0
= SCM_ARRAY_V (ra0
);
1323 if (SCM_NULLP (ras
))
1325 scm_array_set_x (ra0
, scm_apply (proc
, SCM_EOL
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1328 SCM ra1
= SCM_CAR (ras
);
1329 SCM args
, *ve
= &ras
;
1330 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1331 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1332 ra1
= SCM_ARRAY_V (ra1
);
1333 ras
= SCM_CDR (ras
);
1338 ras
= scm_vector (ras
);
1339 ve
= SCM_VELTS (ras
);
1341 for (; i
<= n
; i
++, i1
+= inc1
)
1344 for (k
= SCM_LENGTH (ras
); k
--;)
1345 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1346 args
= scm_cons (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1347 scm_array_set_x (ra0
, scm_apply (proc
, args
, SCM_EOL
), SCM_MAKINUM (i
* inc
+ base
));
1355 ramap_cxr (SCM ra0
,SCM proc
,SCM ras
)
1357 SCM ra1
= SCM_CAR (ras
);
1358 SCM e1
= SCM_UNDEFINED
;
1359 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1360 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1361 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
1362 ra0
= SCM_ARRAY_V (ra0
);
1363 ra1
= SCM_ARRAY_V (ra1
);
1364 switch (SCM_TYP7 (ra0
))
1368 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1369 scm_array_set_x (ra0
, scm_apply (proc
, RVREF (ra1
, i1
, e1
), scm_listofnull
), SCM_MAKINUM (i0
));
1375 float *dst
= (float *) SCM_VELTS (ra0
);
1376 switch (SCM_TYP7 (ra1
))
1381 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1382 dst
[i0
] = SCM_DSUBRF (proc
) ((double) ((float *) SCM_VELTS (ra1
))[i1
]);
1386 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1387 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1392 #endif /* SCM_SINGLES */
1395 double *dst
= (double *) SCM_VELTS (ra0
);
1396 switch (SCM_TYP7 (ra1
))
1401 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1402 dst
[i0
] = SCM_DSUBRF (proc
) (((double *) SCM_VELTS (ra1
))[i1
]);
1406 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1407 dst
[i0
] = SCM_DSUBRF (proc
) ((double) SCM_VELTS (ra1
)[i1
]);
1412 #endif /* SCM_FLOATS */
1420 ramap_rp (SCM ra0
,SCM proc
,SCM ras
)
1422 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
1423 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
1424 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1425 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
1426 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1427 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1428 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
1429 ra0
= SCM_ARRAY_V (ra0
);
1430 ra1
= SCM_ARRAY_V (ra1
);
1431 ra2
= SCM_ARRAY_V (ra2
);
1432 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
1435 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1436 if (BVE_REF (ra0
, i0
))
1437 if (SCM_FALSEP (SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
1442 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1443 if (BVE_REF (ra0
, i0
))
1445 if (SCM_FALSEP (SCM_SUBRF (proc
) (SCM_MAKINUM (SCM_VELTS (ra1
)[i1
]),
1446 SCM_MAKINUM (SCM_VELTS (ra2
)[i2
]))))
1454 SCM a1
= scm_makflo (1.0), a2
= scm_makflo (1.0);
1455 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1456 if (BVE_REF (ra0
, i0
))
1458 SCM_FLO (a1
) = ((float *) SCM_VELTS (ra1
))[i1
];
1459 SCM_FLO (a2
) = ((float *) SCM_VELTS (ra2
))[i2
];
1460 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1465 #endif /*SCM_SINGLES*/
1468 SCM a1
= scm_makdbl (1.0 / 3.0, 0.0), a2
= scm_makdbl (1.0 / 3.0, 0.0);
1469 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1470 if (BVE_REF (ra0
, i0
))
1472 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[i1
];
1473 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[i2
];
1474 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1481 SCM a1
= scm_makdbl (1.0, 1.0), a2
= scm_makdbl (1.0, 1.0);
1482 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1483 if (BVE_REF (ra0
, i0
))
1485 SCM_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
];
1486 SCM_IMAG (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1];
1487 SCM_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
];
1488 SCM_IMAG (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1];
1489 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1494 #endif /*SCM_FLOATS*/
1502 ramap_1 (SCM ra0
,SCM proc
,SCM ras
)
1504 SCM ra1
= SCM_CAR (ras
);
1505 SCM e1
= SCM_UNDEFINED
;
1506 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1507 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1508 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1509 ra0
= SCM_ARRAY_V (ra0
);
1510 ra1
= SCM_ARRAY_V (ra1
);
1511 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1512 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1513 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
)), SCM_MAKINUM (i0
));
1515 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1516 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1523 ramap_2o (SCM ra0
,SCM proc
,SCM ras
)
1525 SCM ra1
= SCM_CAR (ras
);
1526 SCM e1
= SCM_UNDEFINED
;
1527 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1528 scm_sizet i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1529 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1530 ra0
= SCM_ARRAY_V (ra0
);
1531 ra1
= SCM_ARRAY_V (ra1
);
1532 ras
= SCM_CDR (ras
);
1533 if (SCM_NULLP (ras
))
1535 if (scm_tc7_vector
== SCM_TYP7 (ra0
)
1536 || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1538 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1539 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), SCM_UNDEFINED
),
1542 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1543 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), SCM_UNDEFINED
),
1548 SCM ra2
= SCM_CAR (ras
);
1549 SCM e2
= SCM_UNDEFINED
;
1550 scm_sizet i2
= SCM_ARRAY_BASE (ra2
);
1551 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
1552 ra2
= SCM_ARRAY_V (ra2
);
1553 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1554 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1555 scm_array_set_x (ra0
,
1556 SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), scm_cvref (ra2
, i2
, SCM_UNDEFINED
)),
1559 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1560 scm_array_set_x (ra0
,
1561 SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)),
1570 ramap_a (SCM ra0
,SCM proc
,SCM ras
)
1572 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1573 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1574 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1575 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1576 ra0
= SCM_ARRAY_V (ra0
);
1577 if (SCM_NULLP (ras
))
1578 for (; n
-- > 0; i0
+= inc0
)
1579 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1582 SCM ra1
= SCM_CAR (ras
);
1583 scm_sizet i1
= SCM_ARRAY_BASE (ra1
);
1584 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1585 ra1
= SCM_ARRAY_V (ra1
);
1586 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1587 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1593 /* This name is obsolete. Will go away in release 1.5. */
1594 SCM_REGISTER_PROC(s_serial_array_map_x
, "serial-array-map!", 2, 0, 1, scm_array_map_x
);
1595 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
1598 SCM_DEFINE(scm_array_map_x
, "array-map!", 2, 0, 1,
1599 (SCM ra0
, SCM proc
, SCM lra
),
1600 "@var{array1}, @dots{} must have the same number of dimensions as
1601 @var{array0} and have a range for each index which includes the range
1602 for the corresponding index in @var{array0}. @var{proc} is applied to
1603 each tuple of elements of @var{array1} @dots{} and the result is stored
1604 as the corresponding element in @var{array0}. The value returned is
1605 unspecified. The order of application is unspecified.")
1606 #define FUNC_NAME s_scm_array_map_x
1608 SCM_VALIDATE_PROC(2,proc
);
1609 switch (SCM_TYP7 (proc
))
1613 SCM_RAMAPC (ramap
, proc
, ra0
, lra
);
1614 return SCM_UNSPECIFIED
;
1615 case scm_tc7_subr_1
:
1616 SCM_RAMAPC (ramap_1
, proc
, ra0
, lra
);
1617 return SCM_UNSPECIFIED
;
1618 case scm_tc7_subr_2
:
1619 case scm_tc7_subr_2o
:
1620 SCM_RAMAPC (ramap_2o
, proc
, ra0
, lra
);
1621 return SCM_UNSPECIFIED
;
1623 if (!SCM_SUBRF (proc
))
1625 SCM_RAMAPC (ramap_cxr
, proc
, ra0
, lra
);
1626 return SCM_UNSPECIFIED
;
1627 case scm_tc7_rpsubr
:
1630 if (SCM_FALSEP (scm_array_p (ra0
, SCM_BOOL_T
)))
1632 scm_array_fill_x (ra0
, SCM_BOOL_T
);
1633 for (p
= ra_rpsubrs
; p
->name
; p
++)
1634 if (proc
== p
->sproc
)
1636 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1638 SCM_RAMAPC (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
);
1639 lra
= SCM_CDR (lra
);
1641 return SCM_UNSPECIFIED
;
1643 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1645 SCM_RAMAPC (ramap_rp
, proc
, ra0
, lra
);
1646 lra
= SCM_CDR (lra
);
1648 return SCM_UNSPECIFIED
;
1651 if (SCM_NULLP (lra
))
1653 SCM prot
, fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
1654 if (SCM_INUMP(fill
))
1656 prot
= scm_array_prototype (ra0
);
1657 if (SCM_INEXP (prot
))
1658 fill
= scm_makdbl ((double) SCM_INUM (fill
), 0.0);
1661 scm_array_fill_x (ra0
, fill
);
1665 SCM tail
, ra1
= SCM_CAR (lra
);
1666 SCM v0
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
1668 /* Check to see if order might matter.
1669 This might be an argument for a separate
1670 SERIAL-ARRAY-MAP! */
1671 if (v0
== ra1
|| (SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1672 if (ra0
!= ra1
|| (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
1674 for (tail
= SCM_CDR (lra
); SCM_NNULLP (tail
); tail
= SCM_CDR (tail
))
1676 ra1
= SCM_CAR (tail
);
1677 if (v0
== ra1
|| (SCM_ARRAYP (ra1
) && v0
== SCM_ARRAY_V (ra1
)))
1680 for (p
= ra_asubrs
; p
->name
; p
++)
1681 if (proc
== p
->sproc
)
1683 if (ra0
!= SCM_CAR (lra
))
1684 SCM_RAMAPC (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
));
1685 lra
= SCM_CDR (lra
);
1688 SCM_RAMAPC (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
);
1689 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
1690 return SCM_UNSPECIFIED
;
1691 lra
= SCM_CDR (lra
);
1694 SCM_RAMAPC (ramap_2o
, proc
, ra0
, lra
);
1695 lra
= SCM_CDR (lra
);
1697 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
1698 SCM_RAMAPC (ramap_a
, proc
, ra0
, lra
);
1700 return SCM_UNSPECIFIED
;
1707 rafe (SCM ra0
,SCM proc
,SCM ras
)
1709 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1710 scm_sizet i0
= SCM_ARRAY_BASE (ra0
);
1711 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1712 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1713 ra0
= SCM_ARRAY_V (ra0
);
1714 if (SCM_NULLP (ras
))
1715 for (; i
<= n
; i
++, i0
+= inc0
)
1716 scm_apply (proc
, scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_listofnull
);
1719 SCM ra1
= SCM_CAR (ras
);
1720 SCM args
, *ve
= &ras
;
1721 scm_sizet k
, i1
= SCM_ARRAY_BASE (ra1
);
1722 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1723 ra1
= SCM_ARRAY_V (ra1
);
1724 ras
= SCM_CDR (ras
);
1729 ras
= scm_vector (ras
);
1730 ve
= SCM_VELTS (ras
);
1732 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
1735 for (k
= SCM_LENGTH (ras
); k
--;)
1736 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1737 args
= scm_cons2 (scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1738 scm_apply (proc
, args
, SCM_EOL
);
1745 SCM_DEFINE(scm_array_for_each
, "array-for-each", 2, 0, 1,
1746 (SCM proc
, SCM ra0
, SCM lra
),
1747 "@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
1748 in row-major order. The value returned is unspecified.")
1749 #define FUNC_NAME s_scm_array_for_each
1751 SCM_VALIDATE_PROC(1,proc
);
1752 SCM_RAMAPC (rafe
, proc
, ra0
, lra
);
1753 return SCM_UNSPECIFIED
;
1757 SCM_DEFINE(scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
1759 "applies @var{proc} to the indices of each element of @var{array} in
1760 turn, storing the result in the corresponding element. The value
1761 returned and the order of application are unspecified.
1763 One can implement @var{array-indexes} as
1765 (define (array-indexes array)
1766 (let ((ra (apply make-array #f (array-shape array))))
1767 (array-index-map! ra (lambda x x))
1772 (define (apl:index-generator n)
1773 (let ((v (make-uniform-vector n 1)))
1774 (array-index-map! v (lambda (i) i))
1777 #define FUNC_NAME s_scm_array_index_map_x
1780 SCM_VALIDATE_NIM (1,ra
);
1781 SCM_VALIDATE_PROC(2,proc
);
1782 switch (SCM_TYP7(ra
))
1785 badarg
:SCM_WTA (1,ra
);
1786 case scm_tc7_vector
:
1789 SCM
*ve
= SCM_VELTS (ra
);
1790 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1791 ve
[i
] = scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
);
1792 return SCM_UNSPECIFIED
;
1794 case scm_tc7_string
:
1795 case scm_tc7_byvect
:
1800 #ifdef HAVE_LONG_LONGS
1801 case scm_tc7_llvect
:
1806 for (i
= 0; i
< SCM_LENGTH (ra
); i
++)
1807 scm_array_set_x (ra
, scm_apply (proc
, SCM_MAKINUM (i
), scm_listofnull
),
1809 return SCM_UNSPECIFIED
;
1811 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
1814 SCM inds
= scm_make_uve (SCM_ARRAY_NDIM (ra
), SCM_MAKINUM (-1L));
1815 long *vinds
= SCM_VELTS (inds
);
1816 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
1818 return scm_array_set_x (ra
, scm_apply(proc
, SCM_EOL
, SCM_EOL
),
1820 for (k
= 0; k
<= kmax
; k
++)
1821 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1827 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1828 i
= cind (ra
, inds
);
1829 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1831 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1832 args
= scm_cons (SCM_MAKINUM (vinds
[j
]), args
);
1833 scm_array_set_x (SCM_ARRAY_V (ra
),
1834 scm_apply (proc
, args
, SCM_EOL
),
1836 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1841 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1847 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1851 return SCM_UNSPECIFIED
;
1859 raeql_1 (SCM ra0
,SCM as_equal
,SCM ra1
)
1861 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1862 scm_sizet i0
= 0, i1
= 0;
1863 long inc0
= 1, inc1
= 1;
1864 scm_sizet n
= SCM_LENGTH (ra0
);
1865 ra1
= SCM_CAR (ra1
);
1866 if (SCM_ARRAYP(ra0
))
1868 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1869 i0
= SCM_ARRAY_BASE (ra0
);
1870 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1871 ra0
= SCM_ARRAY_V (ra0
);
1873 if (SCM_ARRAYP (ra1
))
1875 i1
= SCM_ARRAY_BASE (ra1
);
1876 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1877 ra1
= SCM_ARRAY_V (ra1
);
1879 switch (SCM_TYP7 (ra0
))
1881 case scm_tc7_vector
:
1884 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1886 if (SCM_FALSEP (as_equal
))
1888 if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1891 else if (SCM_FALSEP (scm_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1895 case scm_tc7_string
:
1896 case scm_tc7_byvect
:
1898 char *v0
= SCM_CHARS (ra0
) + i0
;
1899 char *v1
= SCM_CHARS (ra1
) + i1
;
1900 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1906 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1907 if (BVE_REF (ra0
, i0
) != BVE_REF (ra1
, i1
))
1913 long *v0
= (long *) SCM_VELTS (ra0
) + i0
;
1914 long *v1
= (long *) SCM_VELTS (ra1
) + i1
;
1915 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1922 short *v0
= (short *) SCM_VELTS (ra0
) + i0
;
1923 short *v1
= (short *) SCM_VELTS (ra1
) + i1
;
1924 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1929 #ifdef HAVE_LONG_LONGS
1930 case scm_tc7_llvect
:
1932 long long *v0
= (long long *) SCM_VELTS (ra0
) + i0
;
1933 long long *v1
= (long long *) SCM_VELTS (ra1
) + i1
;
1934 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1944 float *v0
= (float *) SCM_VELTS (ra0
) + i0
;
1945 float *v1
= (float *) SCM_VELTS (ra1
) + i1
;
1946 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1951 #endif /* SCM_SINGLES */
1954 double *v0
= (double *) SCM_VELTS (ra0
) + i0
;
1955 double *v1
= (double *) SCM_VELTS (ra1
) + i1
;
1956 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1963 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
) + i0
;
1964 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
) + i1
;
1965 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1967 if ((*v0
)[0] != (*v1
)[0])
1969 if ((*v0
)[1] != (*v1
)[1])
1974 #endif /* SCM_FLOATS */
1981 raeql (SCM ra0
,SCM as_equal
,SCM ra1
)
1983 SCM v0
= ra0
, v1
= ra1
;
1984 scm_array_dim dim0
, dim1
;
1985 scm_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1986 scm_sizet bas0
= 0, bas1
= 0;
1987 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1988 if (SCM_ARRAYP (ra0
))
1990 ndim
= SCM_ARRAY_NDIM (ra0
);
1991 s0
= SCM_ARRAY_DIMS (ra0
);
1992 bas0
= SCM_ARRAY_BASE (ra0
);
1993 v0
= SCM_ARRAY_V (ra0
);
1999 s0
->ubnd
= SCM_LENGTH (v0
) - 1;
2002 if (SCM_ARRAYP (ra1
))
2004 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
2006 s1
= SCM_ARRAY_DIMS (ra1
);
2007 bas1
= SCM_ARRAY_BASE (ra1
);
2008 v1
= SCM_ARRAY_V (ra1
);
2016 s1
->ubnd
= SCM_LENGTH (v1
) - 1;
2019 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
2021 for (k
= ndim
; k
--;)
2023 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
2027 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
2028 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
2031 if (unroll
&& bas0
== bas1
&& v0
== v1
)
2033 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
2038 scm_raequal (SCM ra0
, SCM ra1
)
2040 return SCM_BOOL(raeql (ra0
, SCM_BOOL_T
, ra1
));
2044 /* GJB:FIXME:: Why not use GUILE_PROC1 for array-equal? */
2045 GUILE_PROC1(scm_array_equal_p
, "array-equal?", scm_tc7_rpsubr
,
2047 "Returns @code{#t} iff all arguments are arrays with the same shape, the
2048 same type, and have corresponding elements which are either
2049 @code{equal?} or @code{array-equal?}. This function differs from
2050 @code{equal?} in that a one dimensional shared array may be
2051 @var{array-equal?} but not @var{equal?} to a vector or uniform vector.")
2052 #define FUNC_NAME s_scm_array_equal_p
2057 static char s_array_equal_p
[] = "array-equal?";
2061 scm_array_equal_p (SCM ra0
, SCM ra1
)
2063 if (SCM_IMP (ra0
) || SCM_IMP (ra1
))
2064 callequal
:return scm_equal_p (ra0
, ra1
);
2065 switch (SCM_TYP7(ra0
))
2070 case scm_tc7_string
:
2071 case scm_tc7_byvect
:
2077 case scm_tc7_vector
:
2081 if (!SCM_ARRAYP (ra0
))
2084 switch (SCM_TYP7 (ra1
))
2089 case scm_tc7_string
:
2090 case scm_tc7_byvect
:
2096 case scm_tc7_vector
:
2100 if (!SCM_ARRAYP (ra1
))
2103 return SCM_BOOL(raeql (ra0
, SCM_BOOL_F
, ra1
));
2109 init_raprocs (ra_iproc
*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_scm_array_for_each
);