1 /* Copyright (C) 1996,1998,2000,2001 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. */
45 Someone should rename this to arraymap.c; that would reflect the
52 #include "libguile/_scm.h"
53 #include "libguile/strings.h"
54 #include "libguile/unif.h"
55 #include "libguile/smob.h"
56 #include "libguile/chars.h"
57 #include "libguile/eq.h"
58 #include "libguile/eval.h"
59 #include "libguile/feature.h"
60 #include "libguile/root.h"
61 #include "libguile/vectors.h"
63 #include "libguile/validate.h"
64 #include "libguile/ramap.h"
75 /* These tables are a kluge that will not scale well when more
76 * vectorized subrs are added. It is tempting to steal some bits from
77 * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
78 * offset into a table of vectorized subrs.
81 static ra_iproc ra_rpsubrs
[] =
83 {"=", SCM_UNDEFINED
, scm_ra_eqp
},
84 {"<", SCM_UNDEFINED
, scm_ra_lessp
},
85 {"<=", SCM_UNDEFINED
, scm_ra_leqp
},
86 {">", SCM_UNDEFINED
, scm_ra_grp
},
87 {">=", SCM_UNDEFINED
, scm_ra_greqp
},
91 static ra_iproc ra_asubrs
[] =
93 {"+", SCM_UNDEFINED
, scm_ra_sum
},
94 {"-", SCM_UNDEFINED
, scm_ra_difference
},
95 {"*", SCM_UNDEFINED
, scm_ra_product
},
96 {"/", SCM_UNDEFINED
, scm_ra_divide
},
102 /* Fast, recycling scm_vector ref */
103 #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
105 /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
107 /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
108 elements of scm_vector operands are not aliased */
110 #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
112 #define IVDEP(test, line) line
117 /* inds must be a uvect or ivect, no check. */
122 Yes, this is really ugly, but it prevents multiple code
124 #define BINARY_ELTS_CODE(OPERATOR, type) \
125 do { type *v0 = (type*)SCM_VELTS (ra0);\
126 type *v1 = (type*)SCM_VELTS (ra1);\
128 for (; n-- > 0; i0 += inc0, i1 += inc1) \
129 v0[i0] OPERATOR v1[i1];) \
132 /* This macro is used for all but binary division and
133 multiplication of complex numbers -- see the expanded
134 version in the functions later in this file */
135 #define BINARY_PAIR_ELTS_CODE(OPERATOR, type) \
136 do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
137 type (*v1)[2] = (type (*)[2]) SCM_VELTS (ra1);\
139 for (; n-- > 0; i0 += inc0, i1 += inc1) {\
140 v0[i0][0] OPERATOR v1[i1][0]; \
141 v0[i0][1] OPERATOR v1[i1][1]; \
145 #define UNARY_ELTS_CODE(OPERATOR, type) \
146 do { type *v0 = (type *) SCM_VELTS (ra0);\
147 for (; n-- > 0; i0 += inc0) \
148 v0[i0] OPERATOR v0[i0];\
152 /* This macro is used for all but unary divison
153 of complex numbers -- see the expanded version in the
154 function later in this file. */
155 #define UNARY_PAIR_ELTS_CODE(OPERATOR, type) \
156 do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
157 for (; n-- > 0; i0 += inc0) {\
158 v0[i0][0] OPERATOR v0[i0][0];\
159 v0[i0][1] OPERATOR v0[i0][1];\
165 cind (SCM ra
, SCM inds
)
169 long *ve
= (long*) SCM_VELTS (inds
);
170 if (!SCM_ARRAYP (ra
))
172 i
= SCM_ARRAY_BASE (ra
);
173 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
174 i
+= (ve
[k
] - SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * SCM_ARRAY_DIMS (ra
)[k
].inc
;
179 /* Checker for scm_array mapping functions:
180 return values: 4 --> shapes, increments, and bases are the same;
181 3 --> shapes and increments are the same;
182 2 --> shapes are the same;
183 1 --> ras are at least as big as ra0;
188 scm_ra_matchp (SCM ra0
, SCM ras
)
191 scm_t_array_dim dims
;
192 scm_t_array_dim
*s0
= &dims
;
194 unsigned long bas0
= 0;
196 int exact
= 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
197 if (SCM_IMP (ra0
)) return 0;
198 switch (SCM_TYP7 (ra0
))
210 #ifdef HAVE_LONG_LONGS
218 s0
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra0
)) - 1;
221 if (!SCM_ARRAYP (ra0
))
223 ndim
= SCM_ARRAY_NDIM (ra0
);
224 s0
= SCM_ARRAY_DIMS (ra0
);
225 bas0
= SCM_ARRAY_BASE (ra0
);
228 while (SCM_NIMP (ras
))
246 #ifdef HAVE_LONG_LONGS
253 unsigned long int length
;
258 length
= SCM_INUM (scm_uniform_vector_length (ra1
));
269 if ((0 == s0
->lbnd
) && (s0
->ubnd
== length
- 1))
273 if (s0
->lbnd
< 0 || s0
->ubnd
>= length
)
279 if (!SCM_ARRAYP (ra1
) || ndim
!= SCM_ARRAY_NDIM (ra1
))
281 s1
= SCM_ARRAY_DIMS (ra1
);
282 if (bas0
!= SCM_ARRAY_BASE (ra1
))
284 for (i
= 0; i
< ndim
; i
++)
289 if (s0
[i
].inc
!= s1
[i
].inc
)
292 if (s0
[i
].lbnd
== s1
[i
].lbnd
&& s0
[i
].ubnd
== s1
[i
].ubnd
)
296 if (s0
[i
].lbnd
< s1
[i
].lbnd
|| s0
[i
].ubnd
> s1
[i
].ubnd
)
297 return (s0
[i
].lbnd
<= s0
[i
].ubnd
? 0 : 1);
306 /* array mapper: apply cproc to each dimension of the given arrays?.
307 int (*cproc) (); procedure to call on unrolled arrays?
308 cproc (dest, source list) or
309 cproc (dest, data, source list).
310 SCM data; data to give to cproc or unbound.
311 SCM ra0; destination array.
312 SCM lra; list of source arrays.
313 const char *what; caller, for error reporting. */
315 scm_ramapc (int (*cproc
)(), SCM data
, SCM ra0
, SCM lra
, const char *what
)
322 switch (scm_ra_matchp (ra0
, lra
))
326 scm_misc_error (what
, "array shape mismatch: ~S", ra0
);
329 case 4: /* Try unrolling arrays */
330 kmax
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_NDIM (ra0
) - 1 : 0);
333 vra0
= scm_array_contents (ra0
, SCM_UNDEFINED
);
334 if (SCM_IMP (vra0
)) goto gencase
;
335 if (!SCM_ARRAYP (vra0
))
337 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (vra0
));
338 vra1
= scm_make_ra (1);
339 SCM_ARRAY_BASE (vra1
) = 0;
340 SCM_ARRAY_DIMS (vra1
)->lbnd
= 0;
341 SCM_ARRAY_DIMS (vra1
)->ubnd
= length
- 1;
342 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
343 SCM_ARRAY_V (vra1
) = vra0
;
348 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
351 vra1
= scm_make_ra (1);
352 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
353 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
354 if (!SCM_ARRAYP (ra1
))
356 SCM_ARRAY_BASE (vra1
) = 0;
357 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
358 SCM_ARRAY_V (vra1
) = ra1
;
360 else if (!SCM_ARRAY_CONTP (ra1
))
364 SCM_ARRAY_BASE (vra1
) = SCM_ARRAY_BASE (ra1
);
365 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
366 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
368 *plvra
= scm_cons (vra1
, SCM_EOL
);
369 plvra
= SCM_CDRLOC (*plvra
);
371 return (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
));
373 gencase
: /* Have to loop over all dimensions. */
374 vra0
= scm_make_ra (1);
375 if (SCM_ARRAYP (ra0
))
377 kmax
= SCM_ARRAY_NDIM (ra0
) - 1;
380 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
381 SCM_ARRAY_DIMS (vra0
)->ubnd
= 0;
382 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
386 SCM_ARRAY_DIMS (vra0
)->lbnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].lbnd
;
387 SCM_ARRAY_DIMS (vra0
)->ubnd
= SCM_ARRAY_DIMS (ra0
)[kmax
].ubnd
;
388 SCM_ARRAY_DIMS (vra0
)->inc
= SCM_ARRAY_DIMS (ra0
)[kmax
].inc
;
390 SCM_ARRAY_BASE (vra0
) = SCM_ARRAY_BASE (ra0
);
391 SCM_ARRAY_V (vra0
) = SCM_ARRAY_V (ra0
);
395 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra0
));
397 SCM_ARRAY_DIMS (vra0
)->lbnd
= 0;
398 SCM_ARRAY_DIMS (vra0
)->ubnd
= length
- 1;
399 SCM_ARRAY_DIMS (vra0
)->inc
= 1;
400 SCM_ARRAY_BASE (vra0
) = 0;
401 SCM_ARRAY_V (vra0
) = ra0
;
406 for (z
= lra
; SCM_NIMP (z
); z
= SCM_CDR (z
))
409 vra1
= scm_make_ra (1);
410 SCM_ARRAY_DIMS (vra1
)->lbnd
= SCM_ARRAY_DIMS (vra0
)->lbnd
;
411 SCM_ARRAY_DIMS (vra1
)->ubnd
= SCM_ARRAY_DIMS (vra0
)->ubnd
;
412 if (SCM_ARRAYP (ra1
))
415 SCM_ARRAY_DIMS (vra1
)->inc
= SCM_ARRAY_DIMS (ra1
)[kmax
].inc
;
416 SCM_ARRAY_V (vra1
) = SCM_ARRAY_V (ra1
);
420 SCM_ARRAY_DIMS (vra1
)->inc
= 1;
421 SCM_ARRAY_V (vra1
) = ra1
;
423 *plvra
= scm_cons (vra1
, SCM_EOL
);
424 plvra
= SCM_CDRLOC (*plvra
);
426 inds
= scm_make_uve (SCM_ARRAY_NDIM (ra0
), SCM_MAKINUM (-1L));
427 vinds
= (long *) SCM_VELTS (inds
);
428 for (k
= 0; k
<= kmax
; k
++)
429 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
;
436 SCM_ARRAY_BASE (vra0
) = cind (ra0
, inds
);
437 for (z
= lvra
; SCM_NIMP (z
); z
= SCM_CDR (z
), y
= SCM_CDR (y
))
438 SCM_ARRAY_BASE (SCM_CAR (z
)) = cind (SCM_CAR (y
), inds
);
439 if (0 == (SCM_UNBNDP (data
) ? cproc(vra0
, lvra
) : cproc(vra0
, data
, lvra
)))
444 if (vinds
[k
] < SCM_ARRAY_DIMS (ra0
)[k
].ubnd
)
450 vinds
[k
] = SCM_ARRAY_DIMS (ra0
)[k
].lbnd
- 1;
459 SCM_DEFINE (scm_array_fill_x
, "array-fill!", 2, 0, 0,
461 "Stores @var{fill} in every element of @var{array}. The value returned\n"
463 #define FUNC_NAME s_scm_array_fill_x
465 scm_ramapc (scm_array_fill_int
, fill
, ra
, SCM_EOL
, FUNC_NAME
);
466 return SCM_UNSPECIFIED
;
470 /* to be used as cproc in scm_ramapc to fill an array dimension with
473 scm_array_fill_int (SCM ra
, SCM fill
, SCM ignore SCM_UNUSED
)
474 #define FUNC_NAME s_scm_array_fill_x
477 unsigned long n
= SCM_ARRAY_DIMS (ra
)->ubnd
- SCM_ARRAY_DIMS (ra
)->lbnd
+ 1;
478 long inc
= SCM_ARRAY_DIMS (ra
)->inc
;
479 unsigned long base
= SCM_ARRAY_BASE (ra
);
481 ra
= SCM_ARRAY_V (ra
);
485 for (i
= base
; n
--; i
+= inc
)
486 scm_array_set_x (ra
, fill
, SCM_MAKINUM (i
));
490 for (i
= base
; n
--; i
+= inc
)
491 SCM_VELTS (ra
)[i
] = fill
;
494 SCM_ASRTGO (SCM_CHARP (fill
), badarg2
);
495 for (i
= base
; n
--; i
+= inc
)
496 SCM_STRING_CHARS (ra
)[i
] = SCM_CHAR (fill
);
499 if (SCM_CHARP (fill
))
500 fill
= SCM_MAKINUM ((char) SCM_CHAR (fill
));
501 SCM_ASRTGO (SCM_INUMP (fill
)
502 && -128 <= SCM_INUM (fill
) && SCM_INUM (fill
) < 128,
504 for (i
= base
; n
--; i
+= inc
)
505 ((char *) SCM_UVECTOR_BASE (ra
))[i
] = SCM_INUM (fill
);
509 long *ve
= (long *) SCM_VELTS (ra
);
510 if (1 == inc
&& (n
>= SCM_LONG_BIT
|| n
== SCM_BITVECTOR_LENGTH (ra
)))
512 i
= base
/ SCM_LONG_BIT
;
513 if (SCM_FALSEP (fill
))
515 if (base
% SCM_LONG_BIT
) /* leading partial word */
516 ve
[i
++] &= ~(~0L << (base
% SCM_LONG_BIT
));
517 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
519 if ((base
+ n
) % SCM_LONG_BIT
) /* trailing partial word */
520 ve
[i
] &= (~0L << ((base
+ n
) % SCM_LONG_BIT
));
522 else if (SCM_EQ_P (fill
, SCM_BOOL_T
))
524 if (base
% SCM_LONG_BIT
)
525 ve
[i
++] |= ~0L << (base
% SCM_LONG_BIT
);
526 for (; i
< (base
+ n
) / SCM_LONG_BIT
; i
++)
528 if ((base
+ n
) % SCM_LONG_BIT
)
529 ve
[i
] |= ~(~0L << ((base
+ n
) % SCM_LONG_BIT
));
532 badarg2
:SCM_WRONG_TYPE_ARG (2, fill
);
536 if (SCM_FALSEP (fill
))
537 for (i
= base
; n
--; i
+= inc
)
538 ve
[i
/ SCM_LONG_BIT
] &= ~(1L << (i
% SCM_LONG_BIT
));
539 else if (SCM_EQ_P (fill
, SCM_BOOL_T
))
540 for (i
= base
; n
--; i
+= inc
)
541 ve
[i
/ SCM_LONG_BIT
] |= (1L << (i
% SCM_LONG_BIT
));
549 unsigned long f
= SCM_NUM2ULONG (2, fill
);
550 unsigned long *ve
= (unsigned long *) SCM_VELTS (ra
);
552 for (i
= base
; n
--; i
+= inc
)
558 long f
= SCM_NUM2LONG (2, fill
);
559 long *ve
= (long *) SCM_VELTS (ra
);
561 for (i
= base
; n
--; i
+= inc
)
566 SCM_ASRTGO (SCM_INUMP (fill
), badarg2
);
568 short f
= SCM_INUM (fill
);
569 short *ve
= (short *) SCM_VELTS (ra
);
571 if (f
!= SCM_INUM (fill
))
572 SCM_OUT_OF_RANGE (2, fill
);
573 for (i
= base
; n
--; i
+= inc
)
577 #ifdef HAVE_LONG_LONGS
580 long long f
= SCM_NUM2LONG_LONG (2, fill
);
581 long long *ve
= (long long *) SCM_VELTS (ra
);
583 for (i
= base
; n
--; i
+= inc
)
590 float f
, *ve
= (float *) SCM_VELTS (ra
);
591 SCM_ASRTGO (SCM_REALP (fill
), badarg2
);
592 f
= SCM_REAL_VALUE (fill
);
593 for (i
= base
; n
--; i
+= inc
)
599 double f
, *ve
= (double *) SCM_VELTS (ra
);
600 SCM_ASRTGO (SCM_REALP (fill
), badarg2
);
601 f
= SCM_REAL_VALUE (fill
);
602 for (i
= base
; n
--; i
+= inc
)
609 double (*ve
)[2] = (double (*)[2]) SCM_VELTS (ra
);
610 SCM_ASRTGO (SCM_INEXACTP (fill
), badarg2
);
611 if (SCM_REALP (fill
)) {
612 fr
= SCM_REAL_VALUE (fill
);
615 fr
= SCM_COMPLEX_REAL (fill
);
616 fi
= SCM_COMPLEX_IMAG (fill
);
618 for (i
= base
; n
--; i
+= inc
)
633 racp (SCM src
, SCM dst
)
635 long n
= (SCM_ARRAY_DIMS (src
)->ubnd
- SCM_ARRAY_DIMS (src
)->lbnd
+ 1);
636 long inc_d
, inc_s
= SCM_ARRAY_DIMS (src
)->inc
;
637 unsigned long i_d
, i_s
= SCM_ARRAY_BASE (src
);
639 inc_d
= SCM_ARRAY_DIMS (dst
)->inc
;
640 i_d
= SCM_ARRAY_BASE (dst
);
641 src
= SCM_ARRAY_V (src
);
642 dst
= SCM_ARRAY_V (dst
);
644 switch SCM_TYP7 (dst
)
651 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
652 scm_array_set_x (dst
,
653 scm_cvref (src
, i_s
, SCM_UNDEFINED
),
657 if (SCM_TYP7 (src
) != scm_tc7_string
)
659 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
660 SCM_STRING_CHARS (dst
)[i_d
] = SCM_STRING_CHARS (src
)[i_s
];
663 if (SCM_TYP7 (src
) != scm_tc7_byvect
)
665 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
666 ((char *) SCM_UVECTOR_BASE (dst
))[i_d
]
667 = ((char *) SCM_UVECTOR_BASE (src
))[i_s
];
670 if (SCM_TYP7 (src
) != scm_tc7_bvect
)
672 if (1 == inc_d
&& 1 == inc_s
&& i_s
% SCM_LONG_BIT
== i_d
% SCM_LONG_BIT
&& n
>= SCM_LONG_BIT
)
674 long *sv
= (long *) SCM_VELTS (src
);
675 long *dv
= (long *) SCM_VELTS (dst
);
676 sv
+= i_s
/ SCM_LONG_BIT
;
677 dv
+= i_d
/ SCM_LONG_BIT
;
678 if (i_s
% SCM_LONG_BIT
)
679 { /* leading partial word */
680 *dv
= (*dv
& ~(~0L << (i_s
% SCM_LONG_BIT
))) | (*sv
& (~0L << (i_s
% SCM_LONG_BIT
)));
683 n
-= SCM_LONG_BIT
- (i_s
% SCM_LONG_BIT
);
686 for (; n
>= SCM_LONG_BIT
; n
-= SCM_LONG_BIT
, sv
++, dv
++)
688 if (n
) /* trailing partial word */
689 *dv
= (*dv
& (~0L << n
)) | (*sv
& ~(~0L << n
));
693 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
694 if (SCM_BITVEC_REF(src
, i_s
))
695 SCM_BITVEC_SET(dst
, i_d
);
697 SCM_BITVEC_CLR(dst
, i_d
);
701 if (scm_tc7_uvect
!= SCM_TYP7 (src
))
705 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
707 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
712 if (scm_tc7_uvect
!= SCM_TYP7 (src
) && scm_tc7_ivect
!= SCM_TYP7 (src
))
716 long *d
= (long *) SCM_VELTS (dst
), *s
= (long *) SCM_VELTS (src
);
718 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
724 float *d
= (float *) SCM_VELTS (dst
);
725 float *s
= (float *) SCM_VELTS (src
);
734 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
735 d
[i_d
] = ((long *) s
)[i_s
];)
739 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
744 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
745 d
[i_d
] = ((double *) s
)[i_s
];)
752 double *d
= (double *) SCM_VELTS (dst
);
753 double *s
= (double *) SCM_VELTS (src
);
762 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
763 d
[i_d
] = ((long *) s
)[i_s
];)
767 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
768 d
[i_d
] = ((float *) s
)[i_s
];)
772 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
780 double (*d
)[2] = (double (*)[2]) SCM_VELTS (dst
);
781 double (*s
)[2] = (double (*)[2]) SCM_VELTS (src
);
790 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
792 d
[i_d
][0] = ((long *) s
)[i_s
];
798 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
800 d
[i_d
][0] = ((float *) s
)[i_s
];
806 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
808 d
[i_d
][0] = ((double *) s
)[i_s
];
814 for (; n
-- > 0; i_s
+= inc_s
, i_d
+= inc_d
)
816 d
[i_d
][0] = s
[i_s
][0];
817 d
[i_d
][1] = s
[i_s
][1];
827 SCM_REGISTER_PROC(s_array_copy_in_order_x
, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x
);
830 SCM_DEFINE (scm_array_copy_x
, "array-copy!", 2, 0, 0,
832 "@deffnx primitive array-copy-in-order! src dst\n"
833 "Copies every element from vector or array @var{source} to the\n"
834 "corresponding element of @var{destination}. @var{destination} must have\n"
835 "the same rank as @var{source}, and be at least as large in each\n"
836 "dimension. The order is unspecified.")
837 #define FUNC_NAME s_scm_array_copy_x
839 scm_ramapc (racp
, SCM_UNDEFINED
, src
, scm_cons (dst
, SCM_EOL
), FUNC_NAME
);
840 return SCM_UNSPECIFIED
;
844 /* Functions callable by ARRAY-MAP! */
848 scm_ra_eqp (SCM ra0
, SCM ras
)
850 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
851 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
852 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
853 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
854 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
855 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
856 ra0
= SCM_ARRAY_V (ra0
);
857 ra1
= SCM_ARRAY_V (ra1
);
858 ra2
= SCM_ARRAY_V (ra2
);
859 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
863 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
864 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
865 if (SCM_BITVEC_REF (ra0
, i0
))
866 if (SCM_FALSEP(scm_eq_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
867 SCM_BITVEC_CLR (ra0
, i0
);
871 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
872 if (SCM_BITVEC_REF (ra0
, i0
))
873 if (((unsigned long *) SCM_VELTS (ra1
))[i1
] != ((unsigned long *) SCM_VELTS (ra2
))[i2
])
874 SCM_BITVEC_CLR (ra0
, i0
);
877 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
878 if (SCM_BITVEC_REF (ra0
, i0
))
879 if (((signed long *) SCM_VELTS (ra1
))[i1
] != ((signed long *) SCM_VELTS (ra2
))[i2
])
880 SCM_BITVEC_CLR (ra0
, i0
);
883 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
884 if (SCM_BITVEC_REF (ra0
, i0
))
885 if (((float *) SCM_VELTS (ra1
))[i1
] != ((float *) SCM_VELTS (ra2
))[i2
])
886 SCM_BITVEC_CLR (ra0
, i0
);
889 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
890 if (SCM_BITVEC_REF (ra0
, i0
))
891 if (((double *) SCM_VELTS (ra1
))[i1
] != ((double *) SCM_VELTS (ra2
))[i2
])
892 SCM_BITVEC_CLR (ra0
, i0
);
895 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
896 if (SCM_BITVEC_REF (ra0
, i0
))
897 if (((double *) SCM_VELTS (ra1
))[2 * i1
] != ((double *) SCM_VELTS (ra2
))[2 * i2
] ||
898 ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1] != ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1])
899 SCM_BITVEC_CLR (ra0
, i0
);
905 /* opt 0 means <, nonzero means >= */
908 ra_compare (SCM ra0
,SCM ra1
,SCM ra2
,int opt
)
910 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
911 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
912 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
913 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
914 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
915 ra0
= SCM_ARRAY_V (ra0
);
916 ra1
= SCM_ARRAY_V (ra1
);
917 ra2
= SCM_ARRAY_V (ra2
);
918 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
922 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
923 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
924 if (SCM_BITVEC_REF (ra0
, i0
))
926 SCM_NFALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))) :
927 SCM_FALSEP (scm_less_p (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
928 SCM_BITVEC_CLR (ra0
, i0
);
932 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
934 if (SCM_BITVEC_REF (ra0
, i0
))
936 ((unsigned long *) SCM_VELTS (ra1
))[i1
] < ((unsigned long *) SCM_VELTS (ra2
))[i2
] :
937 ((unsigned long *) SCM_VELTS (ra1
))[i1
] >= ((unsigned long *) SCM_VELTS (ra2
))[i2
])
938 SCM_BITVEC_CLR (ra0
, i0
);
942 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
944 if (SCM_BITVEC_REF (ra0
, i0
))
946 ((signed long *) SCM_VELTS (ra1
))[i1
] < ((signed long *) SCM_VELTS (ra2
))[i2
] :
947 ((signed long *) SCM_VELTS (ra1
))[i1
] >= ((signed long *) SCM_VELTS (ra2
))[i2
])
948 SCM_BITVEC_CLR (ra0
, i0
);
952 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
953 if (SCM_BITVEC_REF(ra0
, i0
))
955 ((float *) SCM_VELTS (ra1
))[i1
] < ((float *) SCM_VELTS (ra2
))[i2
] :
956 ((float *) SCM_VELTS (ra1
))[i1
] >= ((float *) SCM_VELTS (ra2
))[i2
])
957 SCM_BITVEC_CLR (ra0
, i0
);
960 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
961 if (SCM_BITVEC_REF (ra0
, i0
))
963 ((double *) SCM_VELTS (ra1
))[i1
] < ((double *) SCM_VELTS (ra2
))[i2
] :
964 ((double *) SCM_VELTS (ra1
))[i1
] >= ((double *) SCM_VELTS (ra2
))[i2
])
965 SCM_BITVEC_CLR (ra0
, i0
);
974 scm_ra_lessp (SCM ra0
, SCM ras
)
976 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 0);
981 scm_ra_leqp (SCM ra0
, SCM ras
)
983 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 1);
988 scm_ra_grp (SCM ra0
, SCM ras
)
990 return ra_compare (ra0
, SCM_CAR (SCM_CDR (ras
)), SCM_CAR (ras
), 0);
995 scm_ra_greqp (SCM ra0
, SCM ras
)
997 return ra_compare (ra0
, SCM_CAR (ras
), SCM_CAR (SCM_CDR (ras
)), 1);
1002 scm_ra_sum (SCM ra0
, SCM ras
)
1004 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1005 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1006 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1007 ra0
= SCM_ARRAY_V (ra0
);
1008 if (SCM_NNULLP(ras
))
1010 SCM ra1
= SCM_CAR (ras
);
1011 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
1012 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1013 ra1
= SCM_ARRAY_V (ra1
);
1014 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1018 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1019 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1020 scm_array_set_x (ra0
, scm_sum (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1026 BINARY_ELTS_CODE( +=, long);
1028 BINARY_ELTS_CODE( +=, float);
1030 BINARY_ELTS_CODE( +=, double);
1032 BINARY_PAIR_ELTS_CODE( +=, double);
1041 scm_ra_difference (SCM ra0
, SCM ras
)
1043 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1044 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1045 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1046 ra0
= SCM_ARRAY_V (ra0
);
1047 if (SCM_NULLP (ras
))
1049 switch (SCM_TYP7 (ra0
))
1053 SCM e0
= SCM_UNDEFINED
;
1054 for (; n
-- > 0; i0
+= inc0
)
1055 scm_array_set_x (ra0
,
1056 scm_difference (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
),
1061 UNARY_ELTS_CODE( = -, float);
1063 UNARY_ELTS_CODE( = -, double);
1065 UNARY_PAIR_ELTS_CODE( = -, double);
1070 SCM ra1
= SCM_CAR (ras
);
1071 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
1072 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1073 ra1
= SCM_ARRAY_V (ra1
);
1074 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1078 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1079 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1080 scm_array_set_x (ra0
, scm_difference (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1084 BINARY_ELTS_CODE( -=, float);
1086 BINARY_ELTS_CODE( -=, double);
1088 BINARY_PAIR_ELTS_CODE( -=, double);
1097 scm_ra_product (SCM ra0
, SCM ras
)
1099 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1100 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1101 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1102 ra0
= SCM_ARRAY_V (ra0
);
1103 if (SCM_NNULLP (ras
))
1105 SCM ra1
= SCM_CAR (ras
);
1106 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
1107 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1108 ra1
= SCM_ARRAY_V (ra1
);
1109 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1113 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1114 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1115 scm_array_set_x (ra0
, scm_product (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1121 BINARY_ELTS_CODE( *=, long);
1123 BINARY_ELTS_CODE( *=, float);
1125 BINARY_ELTS_CODE( *=, double);
1128 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1130 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1132 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1134 r
= v0
[i0
][0] * v1
[i1
][0] - v0
[i0
][1] * v1
[i1
][1];
1135 v0
[i0
][1] = v0
[i0
][0] * v1
[i1
][1] + v0
[i0
][1] * v1
[i1
][0];
1148 scm_ra_divide (SCM ra0
, SCM ras
)
1150 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1151 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1152 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1153 ra0
= SCM_ARRAY_V (ra0
);
1154 if (SCM_NULLP (ras
))
1156 switch (SCM_TYP7 (ra0
))
1160 SCM e0
= SCM_UNDEFINED
;
1161 for (; n
-- > 0; i0
+= inc0
)
1162 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1166 UNARY_ELTS_CODE( = 1.0 / , float);
1168 UNARY_ELTS_CODE( = 1.0 / , double);
1172 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1173 for (; n
-- > 0; i0
+= inc0
)
1175 d
= v0
[i0
][0] * v0
[i0
][0] + v0
[i0
][1] * v0
[i0
][1];
1185 SCM ra1
= SCM_CAR (ras
);
1186 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
1187 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1188 ra1
= SCM_ARRAY_V (ra1
);
1189 switch (SCM_TYP7 (ra0
) == SCM_TYP7 (ra1
) ? SCM_TYP7 (ra0
) : 0)
1193 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1194 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1195 scm_array_set_x (ra0
, scm_divide (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1199 BINARY_ELTS_CODE( /=, float);
1201 BINARY_ELTS_CODE( /=, double);
1204 register double d
, r
;
1205 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
);
1206 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
);
1208 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1210 d
= v1
[i1
][0] * v1
[i1
][0] + v1
[i1
][1] * v1
[i1
][1];
1211 r
= (v0
[i0
][0] * v1
[i1
][0] + v0
[i0
][1] * v1
[i1
][1]) / d
;
1212 v0
[i0
][1] = (v0
[i0
][1] * v1
[i1
][0] - v0
[i0
][0] * v1
[i1
][1]) / d
;
1225 scm_array_identity (SCM dst
, SCM src
)
1227 return racp (SCM_CAR (src
), scm_cons (dst
, SCM_EOL
));
1233 ramap (SCM ra0
,SCM proc
,SCM ras
)
1235 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1236 long inc
= SCM_ARRAY_DIMS (ra0
)->inc
;
1237 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1238 long base
= SCM_ARRAY_BASE (ra0
) - i
* inc
;
1239 ra0
= SCM_ARRAY_V (ra0
);
1240 if (SCM_NULLP (ras
))
1242 scm_array_set_x (ra0
, scm_call_0 (proc
), SCM_MAKINUM (i
* inc
+ base
));
1245 SCM ra1
= SCM_CAR (ras
);
1246 SCM args
, *ve
= &ras
;
1247 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
1248 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1249 ra1
= SCM_ARRAY_V (ra1
);
1250 ras
= SCM_CDR (ras
);
1255 ras
= scm_vector (ras
);
1256 ve
= SCM_VELTS (ras
);
1258 for (; i
<= n
; i
++, i1
+= inc1
)
1261 for (k
= SCM_INUM (scm_uniform_vector_length (ras
)); k
--;)
1262 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1263 args
= scm_cons (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1264 scm_array_set_x (ra0
, scm_apply_0 (proc
, args
), SCM_MAKINUM (i
* inc
+ base
));
1272 ramap_cxr (SCM ra0
,SCM proc
,SCM ras
)
1274 SCM ra1
= SCM_CAR (ras
);
1275 SCM e1
= SCM_UNDEFINED
;
1276 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1277 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1278 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra1
)->lbnd
+ 1;
1279 ra0
= SCM_ARRAY_V (ra0
);
1280 ra1
= SCM_ARRAY_V (ra1
);
1281 switch (SCM_TYP7 (ra0
))
1285 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1286 scm_array_set_x (ra0
, scm_call_1 (proc
, RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1290 float *dst
= (float *) SCM_VELTS (ra0
);
1291 switch (SCM_TYP7 (ra1
))
1296 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1297 dst
[i0
] = SCM_DSUBRF (proc
) ((double) ((float *) SCM_VELTS (ra1
))[i1
]);
1301 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1302 dst
[i0
] = SCM_DSUBRF (proc
) (SCM_UNPACK (SCM_VELTS (ra1
)[i1
]));
1309 double *dst
= (double *) SCM_VELTS (ra0
);
1310 switch (SCM_TYP7 (ra1
))
1315 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1316 dst
[i0
] = SCM_DSUBRF (proc
) (((double *) SCM_VELTS (ra1
))[i1
]);
1320 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1321 dst
[i0
] = SCM_DSUBRF (proc
) (SCM_UNPACK (SCM_VELTS (ra1
)[i1
]));
1333 ramap_rp (SCM ra0
,SCM proc
,SCM ras
)
1335 SCM ra1
= SCM_CAR (ras
), ra2
= SCM_CAR (SCM_CDR (ras
));
1336 SCM e1
= SCM_UNDEFINED
, e2
= SCM_UNDEFINED
;
1337 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1338 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
), i2
= SCM_ARRAY_BASE (ra2
);
1339 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1340 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1341 long inc2
= SCM_ARRAY_DIMS (ra1
)->inc
;
1342 ra0
= SCM_ARRAY_V (ra0
);
1343 ra1
= SCM_ARRAY_V (ra1
);
1344 ra2
= SCM_ARRAY_V (ra2
);
1345 switch (SCM_TYP7 (ra1
) == SCM_TYP7 (ra2
) ? SCM_TYP7 (ra1
) : 0)
1348 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1349 if (SCM_BITVEC_REF (ra0
, i0
))
1350 if (SCM_FALSEP (SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
))))
1351 SCM_BITVEC_CLR (ra0
, i0
);
1355 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1356 if (SCM_BITVEC_REF (ra0
, i0
))
1358 /* DIRK:FIXME:: There should be a way to access the elements
1359 of a cell as raw data. Further: How can we be sure that
1360 the values fit into an inum?
1362 SCM n1
= SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra1
)))[i1
]);
1363 SCM n2
= SCM_MAKINUM (((long *) SCM_UNPACK (SCM_CDR (ra2
)))[i2
]);
1364 if (SCM_FALSEP (SCM_SUBRF (proc
) (n1
, n2
)))
1365 SCM_BITVEC_CLR (ra0
, i0
);
1370 SCM a1
= scm_make_real (1.0), a2
= scm_make_real (1.0);
1371 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1372 if (SCM_BITVEC_REF (ra0
, i0
))
1374 SCM_REAL_VALUE (a1
) = ((float *) SCM_VELTS (ra1
))[i1
];
1375 SCM_REAL_VALUE (a2
) = ((float *) SCM_VELTS (ra2
))[i2
];
1376 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1377 SCM_BITVEC_CLR (ra0
, i0
);
1383 SCM a1
= scm_make_real (1.0 / 3.0);
1384 SCM a2
= scm_make_real (1.0 / 3.0);
1385 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1386 if (SCM_BITVEC_REF (ra0
, i0
))
1388 SCM_REAL_VALUE (a1
) = ((double *) SCM_VELTS (ra1
))[i1
];
1389 SCM_REAL_VALUE (a2
) = ((double *) SCM_VELTS (ra2
))[i2
];
1390 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1391 SCM_BITVEC_CLR (ra0
, i0
);
1397 SCM a1
= scm_make_complex (1.0, 1.0);
1398 SCM a2
= scm_make_complex (1.0, 1.0);
1399 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1400 if (SCM_BITVEC_REF (ra0
, i0
))
1402 SCM_COMPLEX_REAL (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
];
1403 SCM_COMPLEX_IMAG (a1
) = ((double *) SCM_VELTS (ra1
))[2 * i1
+ 1];
1404 SCM_COMPLEX_REAL (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
];
1405 SCM_COMPLEX_IMAG (a2
) = ((double *) SCM_VELTS (ra2
))[2 * i2
+ 1];
1406 if (SCM_FALSEP (SCM_SUBRF (proc
) (a1
, a2
)))
1407 SCM_BITVEC_CLR (ra0
, i0
);
1418 ramap_1 (SCM ra0
,SCM proc
,SCM ras
)
1420 SCM ra1
= SCM_CAR (ras
);
1421 SCM e1
= SCM_UNDEFINED
;
1422 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1423 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1424 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1425 ra0
= SCM_ARRAY_V (ra0
);
1426 ra1
= SCM_ARRAY_V (ra1
);
1427 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1428 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1429 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
)), SCM_MAKINUM (i0
));
1431 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1432 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
)), SCM_MAKINUM (i0
));
1439 ramap_2o (SCM ra0
,SCM proc
,SCM ras
)
1441 SCM ra1
= SCM_CAR (ras
);
1442 SCM e1
= SCM_UNDEFINED
;
1443 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1444 unsigned long i0
= SCM_ARRAY_BASE (ra0
), i1
= SCM_ARRAY_BASE (ra1
);
1445 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
, inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1446 ra0
= SCM_ARRAY_V (ra0
);
1447 ra1
= SCM_ARRAY_V (ra1
);
1448 ras
= SCM_CDR (ras
);
1449 if (SCM_NULLP (ras
))
1451 if (scm_tc7_vector
== SCM_TYP7 (ra0
)
1452 || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1454 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1455 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), SCM_UNDEFINED
),
1458 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1459 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), SCM_UNDEFINED
),
1464 SCM ra2
= SCM_CAR (ras
);
1465 SCM e2
= SCM_UNDEFINED
;
1466 unsigned long i2
= SCM_ARRAY_BASE (ra2
);
1467 long inc2
= SCM_ARRAY_DIMS (ra2
)->inc
;
1468 ra2
= SCM_ARRAY_V (ra2
);
1469 if (scm_tc7_vector
== SCM_TYP7 (ra0
) || scm_tc7_wvect
== SCM_TYP7 (ra0
))
1470 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1471 scm_array_set_x (ra0
,
1472 SCM_SUBRF (proc
) (scm_cvref (ra1
, i1
, SCM_UNDEFINED
), scm_cvref (ra2
, i2
, SCM_UNDEFINED
)),
1475 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
, i2
+= inc2
)
1476 scm_array_set_x (ra0
,
1477 SCM_SUBRF (proc
) (RVREF (ra1
, i1
, e1
), RVREF (ra2
, i2
, e2
)),
1486 ramap_a (SCM ra0
,SCM proc
,SCM ras
)
1488 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1489 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1490 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1491 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1492 ra0
= SCM_ARRAY_V (ra0
);
1493 if (SCM_NULLP (ras
))
1494 for (; n
-- > 0; i0
+= inc0
)
1495 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), SCM_UNDEFINED
), SCM_MAKINUM (i0
));
1498 SCM ra1
= SCM_CAR (ras
);
1499 unsigned long i1
= SCM_ARRAY_BASE (ra1
);
1500 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1501 ra1
= SCM_ARRAY_V (ra1
);
1502 for (; n
-- > 0; i0
+= inc0
, i1
+= inc1
)
1503 scm_array_set_x (ra0
, SCM_SUBRF (proc
) (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
)),
1510 SCM_REGISTER_PROC(s_array_map_in_order_x
, "array-map-in-order!", 2, 0, 1, scm_array_map_x
);
1513 SCM_DEFINE (scm_array_map_x
, "array-map!", 2, 0, 1,
1514 (SCM ra0
, SCM proc
, SCM lra
),
1515 "@deffnx primitive array-map-in-order! ra0 proc . lra\n"
1516 "@var{array1}, @dots{} must have the same number of dimensions as\n"
1517 "@var{array0} and have a range for each index which includes the range\n"
1518 "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
1519 "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
1520 "as the corresponding element in @var{array0}. The value returned is\n"
1521 "unspecified. The order of application is unspecified.")
1522 #define FUNC_NAME s_scm_array_map_x
1524 SCM_VALIDATE_PROC (2,proc
);
1525 SCM_VALIDATE_REST_ARGUMENT (lra
);
1526 switch (SCM_TYP7 (proc
))
1530 scm_ramapc (ramap
, proc
, ra0
, lra
, FUNC_NAME
);
1531 return SCM_UNSPECIFIED
;
1532 case scm_tc7_subr_1
:
1533 scm_ramapc (ramap_1
, proc
, ra0
, lra
, FUNC_NAME
);
1534 return SCM_UNSPECIFIED
;
1535 case scm_tc7_subr_2
:
1536 case scm_tc7_subr_2o
:
1537 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
1538 return SCM_UNSPECIFIED
;
1540 if (!SCM_SUBRF (proc
))
1542 scm_ramapc (ramap_cxr
, proc
, ra0
, lra
, FUNC_NAME
);
1543 return SCM_UNSPECIFIED
;
1544 case scm_tc7_rpsubr
:
1547 if (SCM_FALSEP (scm_array_p (ra0
, SCM_BOOL_T
)))
1549 scm_array_fill_x (ra0
, SCM_BOOL_T
);
1550 for (p
= ra_rpsubrs
; p
->name
; p
++)
1551 if (SCM_EQ_P (proc
, p
->sproc
))
1553 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1555 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
1556 lra
= SCM_CDR (lra
);
1558 return SCM_UNSPECIFIED
;
1560 while (SCM_NNULLP (lra
) && SCM_NNULLP (SCM_CDR (lra
)))
1562 scm_ramapc (ramap_rp
, proc
, ra0
, lra
, FUNC_NAME
);
1563 lra
= SCM_CDR (lra
);
1565 return SCM_UNSPECIFIED
;
1568 if (SCM_NULLP (lra
))
1570 SCM prot
, fill
= SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
);
1571 if (SCM_INUMP(fill
))
1573 prot
= scm_array_prototype (ra0
);
1574 if (SCM_INEXACTP (prot
))
1575 fill
= scm_make_real ((double) SCM_INUM (fill
));
1578 scm_array_fill_x (ra0
, fill
);
1582 SCM tail
, ra1
= SCM_CAR (lra
);
1583 SCM v0
= (SCM_ARRAYP (ra0
) ? SCM_ARRAY_V (ra0
) : ra0
);
1585 /* Check to see if order might matter.
1586 This might be an argument for a separate
1587 SERIAL-ARRAY-MAP! */
1588 if (SCM_EQ_P (v0
, ra1
)
1589 || (SCM_ARRAYP (ra1
) && SCM_EQ_P (v0
, SCM_ARRAY_V (ra1
))))
1590 if (!SCM_EQ_P (ra0
, ra1
)
1591 || (SCM_ARRAYP(ra0
) && !SCM_ARRAY_CONTP(ra0
)))
1593 for (tail
= SCM_CDR (lra
); SCM_NNULLP (tail
); tail
= SCM_CDR (tail
))
1595 ra1
= SCM_CAR (tail
);
1596 if (SCM_EQ_P (v0
, ra1
)
1597 || (SCM_ARRAYP (ra1
) && SCM_EQ_P (v0
, SCM_ARRAY_V (ra1
))))
1600 for (p
= ra_asubrs
; p
->name
; p
++)
1601 if (SCM_EQ_P (proc
, p
->sproc
))
1603 if (!SCM_EQ_P (ra0
, SCM_CAR (lra
)))
1604 scm_ramapc (scm_array_identity
, SCM_UNDEFINED
, ra0
, scm_cons (SCM_CAR (lra
), SCM_EOL
), FUNC_NAME
);
1605 lra
= SCM_CDR (lra
);
1608 scm_ramapc (p
->vproc
, SCM_UNDEFINED
, ra0
, lra
, FUNC_NAME
);
1609 if (SCM_IMP (lra
) || SCM_IMP (SCM_CDR (lra
)))
1610 return SCM_UNSPECIFIED
;
1611 lra
= SCM_CDR (lra
);
1614 scm_ramapc (ramap_2o
, proc
, ra0
, lra
, FUNC_NAME
);
1615 lra
= SCM_CDR (lra
);
1617 for (lra
= SCM_CDR (lra
); SCM_NIMP (lra
); lra
= SCM_CDR (lra
))
1618 scm_ramapc (ramap_a
, proc
, ra0
, lra
, FUNC_NAME
);
1620 return SCM_UNSPECIFIED
;
1627 rafe (SCM ra0
,SCM proc
,SCM ras
)
1629 long i
= SCM_ARRAY_DIMS (ra0
)->lbnd
;
1630 unsigned long i0
= SCM_ARRAY_BASE (ra0
);
1631 long inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1632 long n
= SCM_ARRAY_DIMS (ra0
)->ubnd
;
1633 ra0
= SCM_ARRAY_V (ra0
);
1634 if (SCM_NULLP (ras
))
1635 for (; i
<= n
; i
++, i0
+= inc0
)
1636 scm_call_1 (proc
, scm_cvref (ra0
, i0
, SCM_UNDEFINED
));
1639 SCM ra1
= SCM_CAR (ras
);
1640 SCM args
, *ve
= &ras
;
1641 unsigned long k
, i1
= SCM_ARRAY_BASE (ra1
);
1642 long inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1643 ra1
= SCM_ARRAY_V (ra1
);
1644 ras
= SCM_CDR (ras
);
1649 ras
= scm_vector (ras
);
1650 ve
= SCM_VELTS (ras
);
1652 for (; i
<= n
; i
++, i0
+= inc0
, i1
+= inc1
)
1655 for (k
= SCM_INUM (scm_uniform_vector_length (ras
)); k
--;)
1656 args
= scm_cons (scm_uniform_vector_ref (ve
[k
], SCM_MAKINUM (i
)), args
);
1657 args
= scm_cons2 (scm_cvref (ra0
, i0
, SCM_UNDEFINED
), scm_cvref (ra1
, i1
, SCM_UNDEFINED
), args
);
1658 scm_apply_0 (proc
, args
);
1665 SCM_DEFINE (scm_array_for_each
, "array-for-each", 2, 0, 1,
1666 (SCM proc
, SCM ra0
, SCM lra
),
1667 "@var{proc} is applied to each tuple of elements of @var{array0} @dots{}\n"
1668 "in row-major order. The value returned is unspecified.")
1669 #define FUNC_NAME s_scm_array_for_each
1671 SCM_VALIDATE_PROC (1,proc
);
1672 SCM_VALIDATE_REST_ARGUMENT (lra
);
1673 scm_ramapc (rafe
, proc
, ra0
, lra
, FUNC_NAME
);
1674 return SCM_UNSPECIFIED
;
1678 SCM_DEFINE (scm_array_index_map_x
, "array-index-map!", 2, 0, 0,
1680 "applies @var{proc} to the indices of each element of @var{array} in\n"
1681 "turn, storing the result in the corresponding element. The value\n"
1682 "returned and the order of application are unspecified.\n\n"
1683 "One can implement @var{array-indexes} as\n"
1685 "(define (array-indexes array)\n"
1686 " (let ((ra (apply make-array #f (array-shape array))))\n"
1687 " (array-index-map! ra (lambda x x))\n"
1690 "Another example:\n"
1692 "(define (apl:index-generator n)\n"
1693 " (let ((v (make-uniform-vector n 1)))\n"
1694 " (array-index-map! v (lambda (i) i))\n"
1697 #define FUNC_NAME s_scm_array_index_map_x
1700 SCM_VALIDATE_NIM (1,ra
);
1701 SCM_VALIDATE_PROC (2,proc
);
1702 switch (SCM_TYP7(ra
))
1705 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
1706 case scm_tc7_vector
:
1709 SCM
*ve
= SCM_VELTS (ra
);
1710 for (i
= 0; i
< SCM_VECTOR_LENGTH (ra
); i
++)
1711 ve
[i
] = scm_call_1 (proc
, SCM_MAKINUM (i
));
1712 return SCM_UNSPECIFIED
;
1714 case scm_tc7_string
:
1715 case scm_tc7_byvect
:
1720 #ifdef HAVE_LONG_LONGS
1721 case scm_tc7_llvect
:
1727 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
1728 for (i
= 0; i
< length
; i
++)
1729 scm_array_set_x (ra
, scm_call_1 (proc
, SCM_MAKINUM (i
)),
1731 return SCM_UNSPECIFIED
;
1734 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
1737 SCM inds
= scm_make_uve (SCM_ARRAY_NDIM (ra
), SCM_MAKINUM (-1L));
1738 long *vinds
= (long *) SCM_VELTS (inds
);
1739 int j
, k
, kmax
= SCM_ARRAY_NDIM (ra
) - 1;
1741 return scm_array_set_x (ra
, scm_call_0 (proc
), SCM_EOL
);
1742 for (k
= 0; k
<= kmax
; k
++)
1743 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1749 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1750 i
= cind (ra
, inds
);
1751 for (; vinds
[k
] <= SCM_ARRAY_DIMS (ra
)[k
].ubnd
; vinds
[k
]++)
1753 for (j
= kmax
+ 1, args
= SCM_EOL
; j
--;)
1754 args
= scm_cons (SCM_MAKINUM (vinds
[j
]), args
);
1755 scm_array_set_x (SCM_ARRAY_V (ra
),
1756 scm_apply_0 (proc
, args
),
1758 i
+= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1763 if (vinds
[k
] < SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
1769 vinds
[k
] = SCM_ARRAY_DIMS (ra
)[k
].lbnd
- 1;
1773 return SCM_UNSPECIFIED
;
1781 raeql_1 (SCM ra0
,SCM as_equal
,SCM ra1
)
1783 SCM e0
= SCM_UNDEFINED
, e1
= SCM_UNDEFINED
;
1784 unsigned long i0
= 0, i1
= 0;
1785 long inc0
= 1, inc1
= 1;
1787 ra1
= SCM_CAR (ra1
);
1788 if (SCM_ARRAYP(ra0
))
1790 n
= SCM_ARRAY_DIMS (ra0
)->ubnd
- SCM_ARRAY_DIMS (ra0
)->lbnd
+ 1;
1791 i0
= SCM_ARRAY_BASE (ra0
);
1792 inc0
= SCM_ARRAY_DIMS (ra0
)->inc
;
1793 ra0
= SCM_ARRAY_V (ra0
);
1796 n
= SCM_INUM (scm_uniform_vector_length (ra0
));
1797 if (SCM_ARRAYP (ra1
))
1799 i1
= SCM_ARRAY_BASE (ra1
);
1800 inc1
= SCM_ARRAY_DIMS (ra1
)->inc
;
1801 ra1
= SCM_ARRAY_V (ra1
);
1803 switch (SCM_TYP7 (ra0
))
1805 case scm_tc7_vector
:
1808 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1810 if (SCM_FALSEP (as_equal
))
1812 if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1815 else if (SCM_FALSEP (scm_equal_p (RVREF (ra0
, i0
, e0
), RVREF (ra1
, i1
, e1
))))
1819 case scm_tc7_string
:
1821 char *v0
= SCM_STRING_CHARS (ra0
) + i0
;
1822 char *v1
= SCM_STRING_CHARS (ra1
) + i1
;
1823 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1828 case scm_tc7_byvect
:
1830 char *v0
= ((char *) SCM_UVECTOR_BASE (ra0
)) + i0
;
1831 char *v1
= ((char *) SCM_UVECTOR_BASE (ra1
)) + i1
;
1832 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1838 for (; n
--; i0
+= inc0
, i1
+= inc1
)
1839 if (SCM_BITVEC_REF (ra0
, i0
) != SCM_BITVEC_REF (ra1
, i1
))
1845 long *v0
= (long *) SCM_VELTS (ra0
) + i0
;
1846 long *v1
= (long *) SCM_VELTS (ra1
) + i1
;
1847 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1854 short *v0
= (short *) SCM_VELTS (ra0
) + i0
;
1855 short *v1
= (short *) SCM_VELTS (ra1
) + i1
;
1856 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1861 #ifdef HAVE_LONG_LONGS
1862 case scm_tc7_llvect
:
1864 long long *v0
= (long long *) SCM_VELTS (ra0
) + i0
;
1865 long long *v1
= (long long *) SCM_VELTS (ra1
) + i1
;
1866 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1874 float *v0
= (float *) SCM_VELTS (ra0
) + i0
;
1875 float *v1
= (float *) SCM_VELTS (ra1
) + i1
;
1876 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1883 double *v0
= (double *) SCM_VELTS (ra0
) + i0
;
1884 double *v1
= (double *) SCM_VELTS (ra1
) + i1
;
1885 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1892 double (*v0
)[2] = (double (*)[2]) SCM_VELTS (ra0
) + i0
;
1893 double (*v1
)[2] = (double (*)[2]) SCM_VELTS (ra1
) + i1
;
1894 for (; n
--; v0
+= inc0
, v1
+= inc1
)
1896 if ((*v0
)[0] != (*v1
)[0])
1898 if ((*v0
)[1] != (*v1
)[1])
1909 raeql (SCM ra0
,SCM as_equal
,SCM ra1
)
1911 SCM v0
= ra0
, v1
= ra1
;
1912 scm_t_array_dim dim0
, dim1
;
1913 scm_t_array_dim
*s0
= &dim0
, *s1
= &dim1
;
1914 unsigned long bas0
= 0, bas1
= 0;
1915 int k
, unroll
= 1, vlen
= 1, ndim
= 1;
1916 if (SCM_ARRAYP (ra0
))
1918 ndim
= SCM_ARRAY_NDIM (ra0
);
1919 s0
= SCM_ARRAY_DIMS (ra0
);
1920 bas0
= SCM_ARRAY_BASE (ra0
);
1921 v0
= SCM_ARRAY_V (ra0
);
1927 s0
->ubnd
= SCM_INUM (scm_uniform_vector_length (v0
)) - 1;
1930 if (SCM_ARRAYP (ra1
))
1932 if (ndim
!= SCM_ARRAY_NDIM (ra1
))
1934 s1
= SCM_ARRAY_DIMS (ra1
);
1935 bas1
= SCM_ARRAY_BASE (ra1
);
1936 v1
= SCM_ARRAY_V (ra1
);
1941 Huh ? Schizophrenic return type. --hwn
1947 s1
->ubnd
= SCM_INUM (scm_uniform_vector_length (v1
)) - 1;
1950 if (SCM_TYP7 (v0
) != SCM_TYP7 (v1
))
1952 for (k
= ndim
; k
--;)
1954 if (s0
[k
].lbnd
!= s1
[k
].lbnd
|| s0
[k
].ubnd
!= s1
[k
].ubnd
)
1958 unroll
= (s0
[k
].inc
== s1
[k
].inc
);
1959 vlen
*= s0
[k
].ubnd
- s1
[k
].lbnd
+ 1;
1962 if (unroll
&& bas0
== bas1
&& SCM_EQ_P (v0
, v1
))
1964 return scm_ramapc (raeql_1
, as_equal
, ra0
, scm_cons (ra1
, SCM_EOL
), "");
1969 scm_raequal (SCM ra0
, SCM ra1
)
1971 return SCM_BOOL(raeql (ra0
, SCM_BOOL_T
, ra1
));
1975 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
1976 SCM_DEFINE1 (scm_array_equal_p
, "array-equal?", scm_tc7_rpsubr
,
1978 "Return @code{#t} iff all arguments are arrays with the same\n"
1979 "shape, the same type, and have corresponding elements which are\n"
1980 "either @code{equal?} or @code{array-equal?}. This function\n"
1981 "differs from @code{equal?} in that a one dimensional shared\n"
1982 "array may be @var{array-equal?} but not @var{equal?} to a\n"
1983 "vector or uniform vector.")
1984 #define FUNC_NAME s_scm_array_equal_p
1990 static char s_array_equal_p
[] = "array-equal?";
1994 scm_array_equal_p (SCM ra0
, SCM ra1
)
1996 if (SCM_IMP (ra0
) || SCM_IMP (ra1
))
1997 callequal
:return scm_equal_p (ra0
, ra1
);
1998 switch (SCM_TYP7(ra0
))
2003 case scm_tc7_string
:
2004 case scm_tc7_byvect
:
2010 case scm_tc7_vector
:
2014 if (!SCM_ARRAYP (ra0
))
2017 switch (SCM_TYP7 (ra1
))
2022 case scm_tc7_string
:
2023 case scm_tc7_byvect
:
2029 case scm_tc7_vector
:
2033 if (!SCM_ARRAYP (ra1
))
2036 return SCM_BOOL(raeql (ra0
, SCM_BOOL_F
, ra1
));
2041 init_raprocs (ra_iproc
*subra
)
2043 for (; subra
->name
; subra
++)
2045 SCM sym
= scm_str2symbol (subra
->name
);
2047 scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_F
);
2048 if (var
!= SCM_BOOL_F
)
2049 subra
->sproc
= SCM_VARIABLE_REF (var
);
2051 subra
->sproc
= SCM_BOOL_F
;
2059 init_raprocs (ra_rpsubrs
);
2060 init_raprocs (ra_asubrs
);
2061 scm_c_define_subr (s_array_equal_p
, scm_tc7_rpsubr
, scm_array_equal_p
);
2062 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_array
)].equalp
= scm_raequal
;
2063 #ifndef SCM_MAGIC_SNARFER
2064 #include "libguile/ramap.x"
2066 scm_add_feature (s_scm_array_for_each
);