Commit | Line | Data |
---|---|---|
72e2b592 | 1 | /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009, |
5e8c9d4a | 2 | * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
65704b98 | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
0f2d19dd | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
0f2d19dd | 13 | * |
73be1d9e MV |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
1bbd0b84 | 19 | |
1bbd0b84 | 20 | |
0f2d19dd JB |
21 | \f |
22 | ||
23 | ||
24 | \f | |
dbb605f5 LC |
25 | #ifdef HAVE_CONFIG_H |
26 | # include <config.h> | |
27 | #endif | |
0f2d19dd | 28 | |
a0599745 | 29 | #include "libguile/_scm.h" |
405aaef9 | 30 | #include "libguile/strings.h" |
2fa901a5 | 31 | #include "libguile/arrays.h" |
a0599745 MD |
32 | #include "libguile/smob.h" |
33 | #include "libguile/chars.h" | |
34 | #include "libguile/eq.h" | |
35 | #include "libguile/eval.h" | |
36 | #include "libguile/feature.h" | |
37 | #include "libguile/root.h" | |
38 | #include "libguile/vectors.h" | |
cf396142 | 39 | #include "libguile/bitvectors.h" |
b4bdadde | 40 | #include "libguile/srfi-4.h" |
1030b450 | 41 | #include "libguile/generalized-arrays.h" |
a0599745 MD |
42 | |
43 | #include "libguile/validate.h" | |
5d1b3b2d | 44 | #include "libguile/array-map.h" |
0f2d19dd JB |
45 | \f |
46 | ||
d66b74dc | 47 | /* The WHAT argument for `scm_gc_malloc ()' et al. */ |
4cde4f63 | 48 | static const char vi_gc_hint[] = "array-indices"; |
d66b74dc | 49 | |
5e8c9d4a DL |
50 | static SCM |
51 | AREF (SCM v, size_t pos) | |
52 | { | |
53 | return scm_c_array_ref_1 (v, pos); | |
54 | } | |
0f2d19dd | 55 | |
5e8c9d4a DL |
56 | static void |
57 | ASET (SCM v, size_t pos, SCM val) | |
58 | { | |
59 | scm_c_array_set_1_x (v, val, pos); | |
60 | } | |
c209c88e | 61 | |
2a8688a9 | 62 | static SCM |
4cde4f63 | 63 | make1array (SCM v, ssize_t inc) |
2a8688a9 DL |
64 | { |
65 | SCM a = scm_i_make_array (1); | |
65704b98 | 66 | SCM_I_ARRAY_SET_BASE (a, 0); |
2a8688a9 DL |
67 | SCM_I_ARRAY_DIMS (a)->lbnd = 0; |
68 | SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1; | |
4cde4f63 | 69 | SCM_I_ARRAY_DIMS (a)->inc = inc; |
65704b98 | 70 | SCM_I_ARRAY_SET_V (a, v); |
2a8688a9 DL |
71 | return a; |
72 | } | |
73 | ||
f26eae9a | 74 | /* Linear index of not-unrolled index set. */ |
4cde4f63 DL |
75 | static size_t |
76 | cindk (SCM ra, ssize_t *ve, int kend) | |
77 | { | |
f26eae9a | 78 | if (SCM_I_ARRAYP (ra)) |
4cde4f63 DL |
79 | { |
80 | int k; | |
81 | size_t i = SCM_I_ARRAY_BASE (ra); | |
82 | for (k = 0; k < kend; ++k) | |
83 | i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc; | |
84 | return i; | |
85 | } | |
f26eae9a DL |
86 | else |
87 | return 0; /* this is BASE */ | |
4cde4f63 DL |
88 | } |
89 | ||
8269f0be | 90 | /* array mapper: apply cproc to each dimension of the given arrays?. |
1bbd0b84 | 91 | int (*cproc) (); procedure to call on unrolled arrays? |
5c11cc9d | 92 | cproc (dest, source list) or |
8269f0be DL |
93 | cproc (dest, data, source list). |
94 | SCM data; data to give to cproc or unbound. | |
1bbd0b84 GB |
95 | SCM ra0; destination array. |
96 | SCM lra; list of source arrays. | |
97 | const char *what; caller, for error reporting. */ | |
f26eae9a DL |
98 | |
99 | #define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd | |
100 | #define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd | |
101 | ||
8269f0be | 102 | int |
10b9343f | 103 | scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) |
0f2d19dd | 104 | { |
13af75bf | 105 | int (*cproc) () = cproc_ptr; |
992904a8 DL |
106 | SCM z, va0, lva, *plva; |
107 | int k, kmax, kroll; | |
108 | ssize_t *vi, inc; | |
109 | size_t len; | |
10b9343f | 110 | |
f26eae9a DL |
111 | /* Prepare reference argument. */ |
112 | if (SCM_I_ARRAYP (ra0)) | |
0f2d19dd | 113 | { |
992904a8 DL |
114 | kmax = SCM_I_ARRAY_NDIM (ra0)-1; |
115 | inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc; | |
116 | va0 = make1array (SCM_I_ARRAY_V (ra0), inc); | |
f26eae9a DL |
117 | |
118 | /* Find unroll depth */ | |
992904a8 | 119 | for (kroll = max(0, kmax); kroll > 0; --kroll) |
1ac534e9 | 120 | { |
992904a8 DL |
121 | inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1); |
122 | if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc) | |
123 | break; | |
1ac534e9 | 124 | } |
f26eae9a DL |
125 | } |
126 | else | |
127 | { | |
128 | kroll = kmax = 0; | |
992904a8 | 129 | va0 = ra0 = make1array (ra0, 1); |
f26eae9a | 130 | } |
4cde4f63 | 131 | |
f26eae9a | 132 | /* Prepare rest arguments. */ |
992904a8 DL |
133 | lva = SCM_EOL; |
134 | plva = &lva; | |
f26eae9a DL |
135 | for (z = lra; !scm_is_null (z); z = SCM_CDR (z)) |
136 | { | |
992904a8 | 137 | SCM va1, ra1 = SCM_CAR (z); |
f26eae9a | 138 | if (SCM_I_ARRAYP (ra1)) |
1ac534e9 | 139 | { |
f26eae9a DL |
140 | if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1) |
141 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); | |
992904a8 DL |
142 | inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc; |
143 | va1 = make1array (SCM_I_ARRAY_V (ra1), inc); | |
b4b33636 | 144 | |
f26eae9a | 145 | /* Check unroll depth. */ |
992904a8 | 146 | for (k = kmax; k > kroll; --k) |
f26eae9a | 147 | { |
992904a8 DL |
148 | ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k); |
149 | if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k)) | |
150 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); | |
151 | inc *= (u0 - l0 + 1); | |
152 | if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc) | |
153 | { | |
154 | kroll = k; | |
f26eae9a | 155 | break; |
992904a8 | 156 | } |
f26eae9a | 157 | } |
b4b33636 | 158 | |
f26eae9a DL |
159 | /* Check matching of not-unrolled axes. */ |
160 | for (; k>=0; --k) | |
161 | if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k)) | |
162 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); | |
163 | } | |
164 | else | |
4cde4f63 | 165 | { |
f26eae9a DL |
166 | if (kmax != 0) |
167 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); | |
992904a8 | 168 | va1 = make1array (ra1, 1); |
f26eae9a | 169 | |
992904a8 | 170 | if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0)) |
f26eae9a | 171 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
4cde4f63 | 172 | } |
992904a8 DL |
173 | *plva = scm_cons (va1, SCM_EOL); |
174 | plva = SCM_CDRLOC (*plva); | |
f26eae9a DL |
175 | } |
176 | ||
992904a8 DL |
177 | /* Check emptiness of not-unrolled axes. */ |
178 | for (k = 0; k < kroll; ++k) | |
179 | if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1)) | |
180 | return 1; | |
181 | ||
f26eae9a | 182 | /* Set unrolled size. */ |
992904a8 DL |
183 | for (len = 1; k <= kmax; ++k) |
184 | len *= (UBND (ra0, k) - LBND (ra0, k) + 1); | |
185 | UBND (va0, 0) = len - 1; | |
186 | for (z = lva; !scm_is_null (z); z = SCM_CDR (z)) | |
187 | UBND (SCM_CAR (z), 0) = len - 1; | |
4cde4f63 | 188 | |
f26eae9a DL |
189 | /* Set starting indices and go. */ |
190 | vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint); | |
191 | for (k = 0; k < kroll; ++k) | |
192 | vi[k] = LBND (ra0, k); | |
193 | do | |
194 | { | |
195 | if (k == kroll) | |
1ac534e9 | 196 | { |
f26eae9a | 197 | SCM y = lra; |
65704b98 | 198 | SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll)); |
992904a8 | 199 | for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y)) |
65704b98 | 200 | SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll)); |
992904a8 DL |
201 | if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva))) |
202 | return 0; | |
203 | --k; | |
f26eae9a | 204 | } |
992904a8 | 205 | else if (vi[k] < UBND (ra0, k)) |
f26eae9a | 206 | { |
992904a8 DL |
207 | ++vi[k]; |
208 | ++k; | |
f26eae9a DL |
209 | } |
210 | else | |
211 | { | |
992904a8 DL |
212 | vi[k] = LBND (ra0, k) - 1; |
213 | --k; | |
1ac534e9 | 214 | } |
0f2d19dd | 215 | } |
f26eae9a DL |
216 | while (k >= 0); |
217 | ||
218 | return 1; | |
0f2d19dd JB |
219 | } |
220 | ||
f26eae9a DL |
221 | #undef UBND |
222 | #undef LBND | |
223 | ||
ab1ca179 DL |
224 | static int |
225 | rafill (SCM dst, SCM fill) | |
226 | { | |
ab1ca179 | 227 | scm_t_array_handle h; |
f26eae9a | 228 | size_t n, i; |
ab1ca179 | 229 | ssize_t inc; |
48ffc52c | 230 | scm_array_get_handle (SCM_I_ARRAY_V (dst), &h); |
13af75bf DL |
231 | i = SCM_I_ARRAY_BASE (dst); |
232 | inc = SCM_I_ARRAY_DIMS (dst)->inc; | |
f26eae9a DL |
233 | n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1); |
234 | dst = SCM_I_ARRAY_V (dst); | |
ab1ca179 DL |
235 | |
236 | for (; n-- > 0; i += inc) | |
cf64dca6 | 237 | h.vset (h.vector, i, fill); |
ab1ca179 DL |
238 | |
239 | scm_array_handle_release (&h); | |
240 | return 1; | |
241 | } | |
0f2d19dd | 242 | |
3b3b36dd | 243 | SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, |
c209c88e | 244 | (SCM ra, SCM fill), |
b7e64f8b BT |
245 | "Store @var{fill} in every element of array @var{ra}. The value\n" |
246 | "returned is unspecified.") | |
1bbd0b84 | 247 | #define FUNC_NAME s_scm_array_fill_x |
ad310508 | 248 | { |
ab1ca179 | 249 | scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME); |
ad310508 MD |
250 | return SCM_UNSPECIFIED; |
251 | } | |
1bbd0b84 | 252 | #undef FUNC_NAME |
ad310508 | 253 | |
0f2d19dd | 254 | |
72e2b592 | 255 | static int |
1bbd0b84 | 256 | racp (SCM src, SCM dst) |
0f2d19dd | 257 | { |
72e2b592 | 258 | scm_t_array_handle h_s, h_d; |
f26eae9a | 259 | size_t n, i_s, i_d; |
72e2b592 DL |
260 | ssize_t inc_s, inc_d; |
261 | ||
0f2d19dd | 262 | dst = SCM_CAR (dst); |
13af75bf DL |
263 | i_s = SCM_I_ARRAY_BASE (src); |
264 | i_d = SCM_I_ARRAY_BASE (dst); | |
265 | inc_s = SCM_I_ARRAY_DIMS (src)->inc; | |
266 | inc_d = SCM_I_ARRAY_DIMS (dst)->inc; | |
f26eae9a DL |
267 | n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1); |
268 | src = SCM_I_ARRAY_V (src); | |
269 | dst = SCM_I_ARRAY_V (dst); | |
c209c88e | 270 | |
f26eae9a DL |
271 | scm_array_get_handle (src, &h_s); |
272 | scm_array_get_handle (dst, &h_d); | |
2c001086 DL |
273 | |
274 | if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM | |
275 | && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) | |
276 | { | |
277 | SCM const * el_s = h_s.elements; | |
278 | SCM * el_d = h_d.writable_elements; | |
279 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) | |
280 | el_d[i_d] = el_s[i_s]; | |
281 | } | |
282 | else | |
283 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) | |
284 | h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s)); | |
72e2b592 DL |
285 | |
286 | scm_array_handle_release (&h_d); | |
287 | scm_array_handle_release (&h_s); | |
288 | ||
0f2d19dd JB |
289 | return 1; |
290 | } | |
291 | ||
1bbd0b84 | 292 | SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); |
1cc91f1b | 293 | |
1bbd0b84 | 294 | |
3b3b36dd | 295 | SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, |
c209c88e | 296 | (SCM src, SCM dst), |
8f85c0c6 | 297 | "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n" |
b7e64f8b BT |
298 | "Copy every element from vector or array @var{src} to the\n" |
299 | "corresponding element of @var{dst}. @var{dst} must have the\n" | |
300 | "same rank as @var{src}, and be at least as large in each\n" | |
b380b885 | 301 | "dimension. The order is unspecified.") |
1bbd0b84 | 302 | #define FUNC_NAME s_scm_array_copy_x |
0f2d19dd | 303 | { |
c209c88e | 304 | scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME); |
0f2d19dd JB |
305 | return SCM_UNSPECIFIED; |
306 | } | |
1bbd0b84 | 307 | #undef FUNC_NAME |
0f2d19dd | 308 | |
0f2d19dd | 309 | |
75a1b26c | 310 | #if SCM_ENABLE_DEPRECATED == 1 |
1cc91f1b | 311 | |
d09b201d DL |
312 | /* to be used as cproc in scm_ramapc to fill an array dimension with |
313 | "fill". */ | |
314 | int | |
315 | scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) | |
316 | { | |
317 | unsigned long i; | |
318 | unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1; | |
319 | long inc = SCM_I_ARRAY_DIMS (ra)->inc; | |
320 | unsigned long base = SCM_I_ARRAY_BASE (ra); | |
321 | ||
322 | ra = SCM_I_ARRAY_V (ra); | |
323 | ||
324 | for (i = base; n--; i += inc) | |
5e8c9d4a | 325 | ASET (ra, i, fill); |
d09b201d DL |
326 | |
327 | return 1; | |
328 | } | |
329 | ||
330 | /* Functions callable by ARRAY-MAP! */ | |
1cc91f1b | 331 | |
0f2d19dd | 332 | int |
1bbd0b84 | 333 | scm_ra_eqp (SCM ra0, SCM ras) |
0f2d19dd JB |
334 | { |
335 | SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); | |
fab07c30 MV |
336 | scm_t_array_handle ra0_handle; |
337 | scm_t_array_dim *ra0_dims; | |
338 | size_t n; | |
339 | ssize_t inc0; | |
340 | size_t i0 = 0; | |
341 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); | |
04b87de5 MV |
342 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
343 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
04b87de5 MV |
344 | ra1 = SCM_I_ARRAY_V (ra1); |
345 | ra2 = SCM_I_ARRAY_V (ra2); | |
fab07c30 MV |
346 | |
347 | scm_array_get_handle (ra0, &ra0_handle); | |
348 | ra0_dims = scm_array_handle_dims (&ra0_handle); | |
349 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; | |
350 | inc0 = ra0_dims[0].inc; | |
351 | ||
399aba0a | 352 | { |
399aba0a | 353 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
fab07c30 | 354 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
5e8c9d4a | 355 | if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2))) |
fab07c30 | 356 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
399aba0a MV |
357 | } |
358 | ||
fab07c30 | 359 | scm_array_handle_release (&ra0_handle); |
0f2d19dd JB |
360 | return 1; |
361 | } | |
362 | ||
363 | /* opt 0 means <, nonzero means >= */ | |
1cc91f1b | 364 | |
0f2d19dd | 365 | static int |
34d19ef6 | 366 | ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) |
0f2d19dd | 367 | { |
fab07c30 MV |
368 | scm_t_array_handle ra0_handle; |
369 | scm_t_array_dim *ra0_dims; | |
370 | size_t n; | |
371 | ssize_t inc0; | |
372 | size_t i0 = 0; | |
373 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); | |
04b87de5 MV |
374 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
375 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
04b87de5 MV |
376 | ra1 = SCM_I_ARRAY_V (ra1); |
377 | ra2 = SCM_I_ARRAY_V (ra2); | |
399aba0a | 378 | |
fab07c30 MV |
379 | scm_array_get_handle (ra0, &ra0_handle); |
380 | ra0_dims = scm_array_handle_dims (&ra0_handle); | |
381 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; | |
382 | inc0 = ra0_dims[0].inc; | |
383 | ||
399aba0a | 384 | { |
399aba0a | 385 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
fab07c30 | 386 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
399aba0a | 387 | if (opt ? |
5e8c9d4a DL |
388 | scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) : |
389 | scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2)))) | |
fab07c30 | 390 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
399aba0a MV |
391 | } |
392 | ||
fab07c30 | 393 | scm_array_handle_release (&ra0_handle); |
0f2d19dd JB |
394 | return 1; |
395 | } | |
396 | ||
397 | ||
1cc91f1b | 398 | |
0f2d19dd | 399 | int |
1bbd0b84 | 400 | scm_ra_lessp (SCM ra0, SCM ras) |
0f2d19dd JB |
401 | { |
402 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); | |
403 | } | |
404 | ||
1cc91f1b | 405 | |
0f2d19dd | 406 | int |
1bbd0b84 | 407 | scm_ra_leqp (SCM ra0, SCM ras) |
0f2d19dd JB |
408 | { |
409 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); | |
410 | } | |
411 | ||
1cc91f1b | 412 | |
0f2d19dd | 413 | int |
1bbd0b84 | 414 | scm_ra_grp (SCM ra0, SCM ras) |
0f2d19dd JB |
415 | { |
416 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); | |
417 | } | |
418 | ||
1cc91f1b | 419 | |
0f2d19dd | 420 | int |
1bbd0b84 | 421 | scm_ra_greqp (SCM ra0, SCM ras) |
0f2d19dd JB |
422 | { |
423 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); | |
424 | } | |
425 | ||
426 | ||
0f2d19dd | 427 | int |
1bbd0b84 | 428 | scm_ra_sum (SCM ra0, SCM ras) |
0f2d19dd | 429 | { |
04b87de5 MV |
430 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
431 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
432 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
433 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 434 | if (!scm_is_null(ras)) |
c209c88e GB |
435 | { |
436 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
437 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
438 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
439 | ra1 = SCM_I_ARRAY_V (ra1); | |
c209c88e GB |
440 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
441 | { | |
442 | default: | |
0f2d19dd | 443 | { |
c209c88e | 444 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 445 | ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1))); |
c209c88e GB |
446 | break; |
447 | } | |
c209c88e GB |
448 | } |
449 | } | |
0f2d19dd JB |
450 | return 1; |
451 | } | |
452 | ||
453 | ||
1cc91f1b | 454 | |
0f2d19dd | 455 | int |
1bbd0b84 | 456 | scm_ra_difference (SCM ra0, SCM ras) |
0f2d19dd | 457 | { |
04b87de5 MV |
458 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
459 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
460 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
461 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 462 | if (scm_is_null (ras)) |
c209c88e GB |
463 | { |
464 | switch (SCM_TYP7 (ra0)) | |
465 | { | |
466 | default: | |
467 | { | |
c209c88e | 468 | for (; n-- > 0; i0 += inc0) |
5e8c9d4a | 469 | ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED)); |
c209c88e GB |
470 | break; |
471 | } | |
c209c88e GB |
472 | } |
473 | } | |
0f2d19dd JB |
474 | else |
475 | { | |
476 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
477 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
478 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
479 | ra1 = SCM_I_ARRAY_V (ra1); | |
0f2d19dd JB |
480 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
481 | { | |
482 | default: | |
483 | { | |
0f2d19dd | 484 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 485 | ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1))); |
0f2d19dd JB |
486 | break; |
487 | } | |
0f2d19dd JB |
488 | } |
489 | } | |
490 | return 1; | |
491 | } | |
492 | ||
493 | ||
1cc91f1b | 494 | |
0f2d19dd | 495 | int |
1bbd0b84 | 496 | scm_ra_product (SCM ra0, SCM ras) |
0f2d19dd | 497 | { |
04b87de5 MV |
498 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
499 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
500 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
501 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 502 | if (!scm_is_null (ras)) |
c209c88e GB |
503 | { |
504 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
505 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
506 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
507 | ra1 = SCM_I_ARRAY_V (ra1); | |
c209c88e GB |
508 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
509 | { | |
510 | default: | |
0f2d19dd | 511 | { |
c209c88e | 512 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 513 | ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1))); |
c209c88e | 514 | } |
c209c88e GB |
515 | } |
516 | } | |
0f2d19dd JB |
517 | return 1; |
518 | } | |
519 | ||
1cc91f1b | 520 | |
0f2d19dd | 521 | int |
1bbd0b84 | 522 | scm_ra_divide (SCM ra0, SCM ras) |
0f2d19dd | 523 | { |
04b87de5 MV |
524 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
525 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
526 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
527 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 528 | if (scm_is_null (ras)) |
c209c88e GB |
529 | { |
530 | switch (SCM_TYP7 (ra0)) | |
531 | { | |
532 | default: | |
533 | { | |
c209c88e | 534 | for (; n-- > 0; i0 += inc0) |
5e8c9d4a | 535 | ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED)); |
c209c88e GB |
536 | break; |
537 | } | |
c209c88e GB |
538 | } |
539 | } | |
0f2d19dd JB |
540 | else |
541 | { | |
542 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
543 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
544 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
545 | ra1 = SCM_I_ARRAY_V (ra1); | |
0f2d19dd JB |
546 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
547 | { | |
548 | default: | |
549 | { | |
0f2d19dd | 550 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
afaf9d0b | 551 | { |
5e8c9d4a DL |
552 | SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1)); |
553 | ASET (ra0, i0, res); | |
afaf9d0b | 554 | } |
0f2d19dd JB |
555 | break; |
556 | } | |
0f2d19dd JB |
557 | } |
558 | } | |
559 | return 1; | |
560 | } | |
561 | ||
1cc91f1b | 562 | |
0f2d19dd | 563 | int |
1bbd0b84 | 564 | scm_array_identity (SCM dst, SCM src) |
0f2d19dd JB |
565 | { |
566 | return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); | |
567 | } | |
568 | ||
75a1b26c | 569 | #endif /* SCM_ENABLE_DEPRECATED */ |
0f2d19dd | 570 | |
75a1b26c | 571 | static int |
34d19ef6 | 572 | ramap (SCM ra0, SCM proc, SCM ras) |
0f2d19dd | 573 | { |
51a1763f | 574 | scm_t_array_handle h0; |
f26eae9a DL |
575 | size_t n, i0; |
576 | ssize_t i, inc0; | |
13af75bf DL |
577 | i0 = SCM_I_ARRAY_BASE (ra0); |
578 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
f26eae9a DL |
579 | i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
580 | n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; | |
581 | ra0 = SCM_I_ARRAY_V (ra0); | |
b98e2f47 | 582 | scm_array_get_handle (ra0, &h0); |
d2e53ed6 | 583 | if (scm_is_null (ras)) |
f26eae9a | 584 | for (; n--; i0 += inc0) |
cf64dca6 | 585 | h0.vset (h0.vector, i0, scm_call_0 (proc)); |
0f2d19dd JB |
586 | else |
587 | { | |
588 | SCM ra1 = SCM_CAR (ras); | |
51a1763f DL |
589 | scm_t_array_handle h1; |
590 | size_t i1; | |
591 | ssize_t inc1; | |
13af75bf DL |
592 | i1 = SCM_I_ARRAY_BASE (ra1); |
593 | inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
9a68d7b3 | 594 | ras = SCM_CDR (ras); |
f26eae9a | 595 | ra1 = SCM_I_ARRAY_V (ra1); |
b98e2f47 | 596 | scm_array_get_handle (ra1, &h1); |
51a1763f | 597 | if (scm_is_null (ras)) |
f26eae9a DL |
598 | for (; n--; i0 += inc0, i1 += inc1) |
599 | h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); | |
9a68d7b3 DL |
600 | else |
601 | { | |
602 | ras = scm_vector (ras); | |
f26eae9a | 603 | for (; n--; i0 += inc0, i1 += inc1, ++i) |
9a68d7b3 DL |
604 | { |
605 | SCM args = SCM_EOL; | |
606 | unsigned long k; | |
607 | for (k = scm_c_vector_length (ras); k--;) | |
5e8c9d4a | 608 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
cf64dca6 AW |
609 | h0.vset (h0.vector, i0, |
610 | scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); | |
9a68d7b3 DL |
611 | } |
612 | } | |
51a1763f | 613 | scm_array_handle_release (&h1); |
0f2d19dd | 614 | } |
51a1763f | 615 | scm_array_handle_release (&h0); |
0f2d19dd JB |
616 | return 1; |
617 | } | |
618 | ||
1cc91f1b | 619 | |
1bbd0b84 | 620 | SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); |
1cc91f1b | 621 | |
718866aa | 622 | SCM_SYMBOL (sym_b, "b"); |
1bbd0b84 | 623 | |
3b3b36dd | 624 | SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, |
c209c88e | 625 | (SCM ra0, SCM proc, SCM lra), |
8f85c0c6 | 626 | "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n" |
b7e64f8b BT |
627 | "@var{array1}, @dots{} must have the same number of dimensions\n" |
628 | "as @var{ra0} and have a range for each index which includes the\n" | |
629 | "range for the corresponding index in @var{ra0}. @var{proc} is\n" | |
630 | "applied to each tuple of elements of @var{array1}, @dots{} and\n" | |
631 | "the result is stored as the corresponding element in @var{ra0}.\n" | |
632 | "The value returned is unspecified. The order of application is\n" | |
633 | "unspecified.") | |
1bbd0b84 | 634 | #define FUNC_NAME s_scm_array_map_x |
0f2d19dd | 635 | { |
34d19ef6 | 636 | SCM_VALIDATE_PROC (2, proc); |
af45e3b0 | 637 | SCM_VALIDATE_REST_ARGUMENT (lra); |
f530e94f | 638 | |
31d845b4 AW |
639 | scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); |
640 | return SCM_UNSPECIFIED; | |
0f2d19dd | 641 | } |
1bbd0b84 | 642 | #undef FUNC_NAME |
0f2d19dd | 643 | |
1cc91f1b | 644 | |
0f2d19dd | 645 | static int |
34d19ef6 | 646 | rafe (SCM ra0, SCM proc, SCM ras) |
0f2d19dd | 647 | { |
c3e3ef6e DL |
648 | ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
649 | size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; | |
650 | ||
651 | scm_t_array_handle h0; | |
f26eae9a | 652 | size_t i0; |
c3e3ef6e | 653 | ssize_t inc0; |
13af75bf DL |
654 | i0 = SCM_I_ARRAY_BASE (ra0); |
655 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
b98e2f47 DL |
656 | ra0 = SCM_I_ARRAY_V (ra0); |
657 | scm_array_get_handle (ra0, &h0); | |
d2e53ed6 | 658 | if (scm_is_null (ras)) |
f26eae9a | 659 | for (; n--; i0 += inc0) |
cf64dca6 | 660 | scm_call_1 (proc, h0.vref (h0.vector, i0)); |
0f2d19dd JB |
661 | else |
662 | { | |
c3e3ef6e | 663 | ras = scm_vector (ras); |
f26eae9a | 664 | for (; n--; i0 += inc0, ++i) |
c3e3ef6e DL |
665 | { |
666 | SCM args = SCM_EOL; | |
667 | unsigned long k; | |
668 | for (k = scm_c_vector_length (ras); k--;) | |
5e8c9d4a | 669 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
cf64dca6 | 670 | scm_apply_1 (proc, h0.vref (h0.vector, i0), args); |
c3e3ef6e | 671 | } |
0f2d19dd | 672 | } |
c3e3ef6e | 673 | scm_array_handle_release (&h0); |
0f2d19dd JB |
674 | return 1; |
675 | } | |
676 | ||
3b3b36dd | 677 | SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, |
c209c88e | 678 | (SCM proc, SCM ra0, SCM lra), |
b7e64f8b | 679 | "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n" |
b380b885 | 680 | "in row-major order. The value returned is unspecified.") |
1bbd0b84 | 681 | #define FUNC_NAME s_scm_array_for_each |
0f2d19dd | 682 | { |
34d19ef6 | 683 | SCM_VALIDATE_PROC (1, proc); |
af45e3b0 | 684 | SCM_VALIDATE_REST_ARGUMENT (lra); |
c209c88e | 685 | scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME); |
0f2d19dd JB |
686 | return SCM_UNSPECIFIED; |
687 | } | |
1bbd0b84 | 688 | #undef FUNC_NAME |
0f2d19dd | 689 | |
828ada13 | 690 | static void |
f0521cda AW |
691 | array_index_map_1 (SCM ra, SCM proc) |
692 | { | |
828ada13 AW |
693 | scm_t_array_handle h; |
694 | ssize_t i, inc; | |
695 | size_t p; | |
828ada13 | 696 | scm_array_get_handle (ra, &h); |
828ada13 AW |
697 | inc = h.dims[0].inc; |
698 | for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc) | |
4cde4f63 | 699 | h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i))); |
828ada13 | 700 | scm_array_handle_release (&h); |
f0521cda AW |
701 | } |
702 | ||
703 | /* Here we assume that the array is a scm_tc7_array, as that is the only | |
704 | kind of array in Guile that supports rank > 1. */ | |
828ada13 | 705 | static void |
f0521cda AW |
706 | array_index_map_n (SCM ra, SCM proc) |
707 | { | |
b7c8836b | 708 | scm_t_array_handle h; |
828ada13 | 709 | size_t i; |
b98e2f47 | 710 | int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1; |
4cde4f63 | 711 | ssize_t *vi; |
b98e2f47 DL |
712 | SCM **si; |
713 | SCM args = SCM_EOL; | |
714 | SCM *p = &args; | |
f0521cda | 715 | |
4cde4f63 | 716 | vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint); |
b98e2f47 | 717 | si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint); |
f0521cda AW |
718 | |
719 | for (k = 0; k <= kmax; k++) | |
b0d9b074 | 720 | { |
4cde4f63 DL |
721 | vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd; |
722 | if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd) | |
b0d9b074 | 723 | return; |
b98e2f47 DL |
724 | *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL); |
725 | si[k] = SCM_CARLOC (*p); | |
726 | p = SCM_CDRLOC (*p); | |
b0d9b074 | 727 | } |
4cde4f63 | 728 | |
b7c8836b | 729 | scm_array_get_handle (ra, &h); |
f0521cda AW |
730 | k = kmax; |
731 | do | |
732 | { | |
733 | if (k == kmax) | |
734 | { | |
4cde4f63 DL |
735 | vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd; |
736 | i = cindk (ra, vi, kmax+1); | |
b98e2f47 | 737 | for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax]) |
f0521cda | 738 | { |
b98e2f47 | 739 | *(si[kmax]) = scm_from_ssize_t (vi[kmax]); |
b7c8836b | 740 | h.vset (h.vector, i, scm_apply_0 (proc, args)); |
4cde4f63 | 741 | i += SCM_I_ARRAY_DIMS (ra)[kmax].inc; |
f0521cda AW |
742 | } |
743 | k--; | |
f0521cda | 744 | } |
4cde4f63 | 745 | else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd) |
f0521cda | 746 | { |
b98e2f47 | 747 | *(si[k]) = scm_from_ssize_t (++vi[k]); |
f0521cda | 748 | k++; |
f0521cda | 749 | } |
b0d9b074 DL |
750 | else |
751 | { | |
4cde4f63 | 752 | vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1; |
b0d9b074 DL |
753 | k--; |
754 | } | |
f0521cda AW |
755 | } |
756 | while (k >= 0); | |
b7c8836b | 757 | scm_array_handle_release (&h); |
f0521cda AW |
758 | } |
759 | ||
3b3b36dd | 760 | SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, |
c209c88e | 761 | (SCM ra, SCM proc), |
b7e64f8b | 762 | "Apply @var{proc} to the indices of each element of @var{ra} in\n" |
b380b885 MD |
763 | "turn, storing the result in the corresponding element. The value\n" |
764 | "returned and the order of application are unspecified.\n\n" | |
765 | "One can implement @var{array-indexes} as\n" | |
1e6808ea | 766 | "@lisp\n" |
b380b885 MD |
767 | "(define (array-indexes array)\n" |
768 | " (let ((ra (apply make-array #f (array-shape array))))\n" | |
769 | " (array-index-map! ra (lambda x x))\n" | |
770 | " ra))\n" | |
1e6808ea | 771 | "@end lisp\n" |
b380b885 | 772 | "Another example:\n" |
1e6808ea | 773 | "@lisp\n" |
b380b885 MD |
774 | "(define (apl:index-generator n)\n" |
775 | " (let ((v (make-uniform-vector n 1)))\n" | |
776 | " (array-index-map! v (lambda (i) i))\n" | |
777 | " v))\n" | |
1e6808ea | 778 | "@end lisp") |
1bbd0b84 | 779 | #define FUNC_NAME s_scm_array_index_map_x |
0f2d19dd | 780 | { |
34d19ef6 | 781 | SCM_VALIDATE_PROC (2, proc); |
399aba0a | 782 | |
f0521cda | 783 | switch (scm_c_array_rank (ra)) |
16259ae3 | 784 | { |
f0521cda AW |
785 | case 0: |
786 | scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); | |
787 | break; | |
788 | case 1: | |
789 | array_index_map_1 (ra, proc); | |
790 | break; | |
791 | default: | |
792 | array_index_map_n (ra, proc); | |
793 | break; | |
16259ae3 | 794 | } |
b4b33636 | 795 | |
f0521cda | 796 | return SCM_UNSPECIFIED; |
0f2d19dd | 797 | } |
1bbd0b84 | 798 | #undef FUNC_NAME |
0f2d19dd | 799 | |
1cc91f1b | 800 | |
0f2d19dd | 801 | static int |
a587d6a9 AW |
802 | array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy, |
803 | size_t dim, unsigned long posx, unsigned long posy) | |
0f2d19dd | 804 | { |
a587d6a9 AW |
805 | if (dim == scm_array_handle_rank (hx)) |
806 | return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx), | |
807 | scm_array_handle_ref (hy, posy))); | |
e466c6a2 | 808 | else |
c209c88e | 809 | { |
a587d6a9 AW |
810 | long incx, incy; |
811 | size_t i; | |
399aba0a | 812 | |
a587d6a9 AW |
813 | if (hx->dims[dim].lbnd != hy->dims[dim].lbnd |
814 | || hx->dims[dim].ubnd != hy->dims[dim].ubnd) | |
815 | return 0; | |
816 | ||
817 | i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1; | |
65704b98 | 818 | |
a587d6a9 AW |
819 | incx = hx->dims[dim].inc; |
820 | incy = hy->dims[dim].inc; | |
821 | posx += (i - 1) * incx; | |
822 | posy += (i - 1) * incy; | |
823 | ||
824 | for (; i > 0; i--, posx -= incx, posy -= incy) | |
825 | if (!array_compare (hx, hy, dim + 1, posx, posy)) | |
826 | return 0; | |
c209c88e | 827 | return 1; |
c209c88e | 828 | } |
0f2d19dd JB |
829 | } |
830 | ||
a587d6a9 AW |
831 | SCM |
832 | scm_array_equal_p (SCM x, SCM y) | |
0f2d19dd | 833 | { |
a587d6a9 | 834 | scm_t_array_handle hx, hy; |
65704b98 DL |
835 | SCM res; |
836 | ||
a587d6a9 AW |
837 | scm_array_get_handle (x, &hx); |
838 | scm_array_get_handle (y, &hy); | |
65704b98 | 839 | |
a587d6a9 AW |
840 | res = scm_from_bool (hx.ndims == hy.ndims |
841 | && hx.element_type == hy.element_type); | |
3ffd1ba9 | 842 | |
a587d6a9 AW |
843 | if (scm_is_true (res)) |
844 | res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0)); | |
0f2d19dd | 845 | |
a587d6a9 AW |
846 | scm_array_handle_release (&hy); |
847 | scm_array_handle_release (&hx); | |
1cc91f1b | 848 | |
a587d6a9 | 849 | return res; |
0f2d19dd JB |
850 | } |
851 | ||
f1d19308 | 852 | static SCM scm_i_array_equal_p (SCM, SCM, SCM); |
31d845b4 AW |
853 | SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, |
854 | (SCM ra0, SCM ra1, SCM rest), | |
1e6808ea MG |
855 | "Return @code{#t} iff all arguments are arrays with the same\n" |
856 | "shape, the same type, and have corresponding elements which are\n" | |
857 | "either @code{equal?} or @code{array-equal?}. This function\n" | |
a587d6a9 | 858 | "differs from @code{equal?} in that all arguments must be arrays.") |
31d845b4 AW |
859 | #define FUNC_NAME s_scm_i_array_equal_p |
860 | { | |
861 | if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1)) | |
862 | return SCM_BOOL_T; | |
65704b98 | 863 | |
31d845b4 | 864 | while (!scm_is_null (rest)) |
8a1f4f98 | 865 | { if (scm_is_false (scm_array_equal_p (ra0, ra1))) |
31d845b4 | 866 | return SCM_BOOL_F; |
8a1f4f98 AW |
867 | ra0 = ra1; |
868 | ra1 = scm_car (rest); | |
31d845b4 AW |
869 | rest = scm_cdr (rest); |
870 | } | |
871 | return scm_array_equal_p (ra0, ra1); | |
0f981281 | 872 | } |
4079f87e | 873 | #undef FUNC_NAME |
0f2d19dd | 874 | |
1cc91f1b | 875 | |
0f2d19dd | 876 | void |
5d1b3b2d | 877 | scm_init_array_map (void) |
0f2d19dd | 878 | { |
5d1b3b2d | 879 | #include "libguile/array-map.x" |
1bbd0b84 | 880 | scm_add_feature (s_scm_array_for_each); |
0f2d19dd | 881 | } |
89e00824 ML |
882 | |
883 | /* | |
884 | Local Variables: | |
885 | c-file-style: "gnu" | |
886 | End: | |
887 | */ |