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. |
0f2d19dd | 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 LC |
47 | /* The WHAT argument for `scm_gc_malloc ()' et al. */ |
48 | static const char indices_gc_hint[] = "array-indices"; | |
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 | |
c014a02e | 62 | static unsigned long |
b4b33636 | 63 | cind (SCM ra, long *ve) |
0f2d19dd | 64 | { |
c014a02e | 65 | unsigned long i; |
0f2d19dd | 66 | int k; |
04b87de5 | 67 | if (!SCM_I_ARRAYP (ra)) |
0f2d19dd | 68 | return *ve; |
04b87de5 MV |
69 | i = SCM_I_ARRAY_BASE (ra); |
70 | for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) | |
71 | i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc; | |
0f2d19dd JB |
72 | return i; |
73 | } | |
74 | ||
75 | ||
76 | /* Checker for scm_array mapping functions: | |
8269f0be DL |
77 | return values: |
78 | 5 --> empty axes; | |
79 | 4 --> shapes, increments, and bases are the same; | |
0f2d19dd JB |
80 | 3 --> shapes and increments are the same; |
81 | 2 --> shapes are the same; | |
82 | 1 --> ras are at least as big as ra0; | |
83 | 0 --> no match. | |
84 | */ | |
1cc91f1b | 85 | |
8269f0be | 86 | int |
6e8d25a6 | 87 | scm_ra_matchp (SCM ra0, SCM ras) |
0f2d19dd | 88 | { |
8269f0be DL |
89 | int i, exact = 4, empty = 0; |
90 | scm_t_array_handle h0; | |
399aba0a | 91 | |
8269f0be DL |
92 | scm_array_get_handle (ra0, &h0); |
93 | for (i = 0; i < h0.ndims; ++i) | |
f0521cda | 94 | { |
8269f0be | 95 | empty = empty || (h0.dims[i].lbnd > h0.dims[i].ubnd); |
f0521cda | 96 | } |
399aba0a | 97 | |
62fdadb0 | 98 | while (scm_is_pair (ras)) |
c209c88e | 99 | { |
8269f0be | 100 | scm_t_array_handle h1; |
16259ae3 | 101 | |
8269f0be | 102 | scm_array_get_handle (SCM_CAR (ras), &h1); |
16259ae3 | 103 | |
8269f0be DL |
104 | if (h0.ndims != h1.ndims) |
105 | { | |
106 | scm_array_handle_release (&h0); | |
107 | scm_array_handle_release (&h1); | |
108 | return 0; | |
109 | } | |
110 | if (h0.base != h1.base) | |
111 | exact = min(3, exact); | |
399aba0a | 112 | |
8269f0be DL |
113 | for (i = 0; i < h0.ndims; ++i) |
114 | { | |
115 | empty = empty || (h1.dims[i].lbnd > h1.dims[i].ubnd); | |
116 | switch (exact) | |
117 | { | |
118 | case 4: | |
119 | case 3: | |
120 | if (h0.dims[i].inc != h1.dims[i].inc) | |
121 | exact = 2; | |
122 | case 2: | |
123 | if (h0.dims[i].lbnd == h1.dims[i].lbnd && h0.dims[i].ubnd == h1.dims[i].ubnd) | |
124 | break; | |
125 | exact = 1; | |
126 | default: | |
127 | if (h0.dims[i].lbnd < h1.dims[i].lbnd || h0.dims[i].ubnd > h1.dims[i].ubnd) | |
128 | { | |
129 | scm_array_handle_release (&h0); | |
130 | scm_array_handle_release (&h1); | |
131 | return 0; | |
132 | } | |
133 | } | |
134 | } | |
135 | scm_array_handle_release (&h1); | |
c209c88e GB |
136 | ras = SCM_CDR (ras); |
137 | } | |
8269f0be DL |
138 | scm_array_handle_release (&h0); |
139 | return empty ? 5 : exact; | |
0f2d19dd JB |
140 | } |
141 | ||
2a8688a9 DL |
142 | |
143 | static SCM | |
144 | make1array (SCM v) | |
145 | { | |
146 | SCM a = scm_i_make_array (1); | |
147 | SCM_I_ARRAY_BASE (a) = 0; | |
148 | SCM_I_ARRAY_DIMS (a)->lbnd = 0; | |
149 | SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1; | |
150 | SCM_I_ARRAY_DIMS (a)->inc = 1; | |
151 | SCM_I_ARRAY_V (a) = v; | |
152 | return a; | |
153 | } | |
154 | ||
8269f0be | 155 | /* array mapper: apply cproc to each dimension of the given arrays?. |
1bbd0b84 | 156 | int (*cproc) (); procedure to call on unrolled arrays? |
5c11cc9d | 157 | cproc (dest, source list) or |
8269f0be DL |
158 | cproc (dest, data, source list). |
159 | SCM data; data to give to cproc or unbound. | |
1bbd0b84 GB |
160 | SCM ra0; destination array. |
161 | SCM lra; list of source arrays. | |
162 | const char *what; caller, for error reporting. */ | |
8269f0be | 163 | int |
10b9343f | 164 | scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) |
0f2d19dd | 165 | { |
b4b33636 | 166 | SCM z; |
2a8688a9 | 167 | SCM vra0; |
0f2d19dd | 168 | SCM lvra, *plvra; |
c014a02e | 169 | long *vinds; |
0f2d19dd | 170 | int k, kmax; |
13af75bf | 171 | int (*cproc) () = cproc_ptr; |
10b9343f | 172 | |
0f2d19dd JB |
173 | switch (scm_ra_matchp (ra0, lra)) |
174 | { | |
175 | default: | |
176 | case 0: | |
9cf5d9b7 | 177 | scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); |
0f2d19dd JB |
178 | case 2: |
179 | case 3: | |
180 | case 4: /* Try unrolling arrays */ | |
04b87de5 | 181 | kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0); |
0f2d19dd JB |
182 | if (kmax < 0) |
183 | goto gencase; | |
184 | vra0 = scm_array_contents (ra0, SCM_UNDEFINED); | |
19239bbf DL |
185 | if (scm_is_false (vra0)) |
186 | goto gencase; | |
04b87de5 | 187 | if (!SCM_I_ARRAYP (vra0)) |
2a8688a9 | 188 | vra0 = make1array (vra0); |
0f2d19dd JB |
189 | lvra = SCM_EOL; |
190 | plvra = &lvra; | |
62fdadb0 | 191 | for (z = lra; scm_is_pair (z); z = SCM_CDR (z)) |
0f2d19dd | 192 | { |
2a8688a9 DL |
193 | SCM ra1 = SCM_CAR (z); |
194 | SCM vra1 = scm_i_make_array (1); | |
04b87de5 MV |
195 | SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; |
196 | SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; | |
197 | if (!SCM_I_ARRAYP (ra1)) | |
0f2d19dd | 198 | { |
04b87de5 MV |
199 | SCM_I_ARRAY_BASE (vra1) = 0; |
200 | SCM_I_ARRAY_DIMS (vra1)->inc = 1; | |
201 | SCM_I_ARRAY_V (vra1) = ra1; | |
0f2d19dd | 202 | } |
04b87de5 | 203 | else if (!SCM_I_ARRAY_CONTP (ra1)) |
0f2d19dd JB |
204 | goto gencase; |
205 | else | |
206 | { | |
04b87de5 MV |
207 | SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1); |
208 | SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc; | |
209 | SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1); | |
0f2d19dd JB |
210 | } |
211 | *plvra = scm_cons (vra1, SCM_EOL); | |
25d8012c | 212 | plvra = SCM_CDRLOC (*plvra); |
0f2d19dd JB |
213 | } |
214 | return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); | |
215 | case 1: | |
216 | gencase: /* Have to loop over all dimensions. */ | |
66b9d7d3 | 217 | vra0 = scm_i_make_array (1); |
1ac534e9 AW |
218 | if (SCM_I_ARRAYP (ra0)) |
219 | { | |
220 | kmax = SCM_I_ARRAY_NDIM (ra0) - 1; | |
221 | if (kmax < 0) | |
222 | { | |
223 | SCM_I_ARRAY_DIMS (vra0)->lbnd = 0; | |
224 | SCM_I_ARRAY_DIMS (vra0)->ubnd = 0; | |
225 | SCM_I_ARRAY_DIMS (vra0)->inc = 1; | |
226 | } | |
227 | else | |
228 | { | |
229 | SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd; | |
230 | SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd; | |
231 | SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc; | |
232 | } | |
233 | SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0); | |
234 | SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0); | |
235 | } | |
236 | else | |
237 | { | |
1ac534e9 | 238 | kmax = 0; |
2a8688a9 | 239 | ra0 = vra0 = make1array(ra0); |
1ac534e9 AW |
240 | } |
241 | lvra = SCM_EOL; | |
242 | plvra = &lvra; | |
2a8688a9 | 243 | for (z = lra; !scm_is_null (z); z = SCM_CDR (z)) |
1ac534e9 | 244 | { |
2a8688a9 DL |
245 | SCM ra1 = SCM_CAR (z); |
246 | SCM vra1 = scm_i_make_array (1); | |
1ac534e9 AW |
247 | SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; |
248 | SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; | |
249 | if (SCM_I_ARRAYP (ra1)) | |
250 | { | |
251 | if (kmax >= 0) | |
252 | SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc; | |
253 | SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1); | |
254 | } | |
255 | else | |
256 | { | |
257 | SCM_I_ARRAY_DIMS (vra1)->inc = 1; | |
258 | SCM_I_ARRAY_V (vra1) = ra1; | |
259 | } | |
260 | *plvra = scm_cons (vra1, SCM_EOL); | |
261 | plvra = SCM_CDRLOC (*plvra); | |
262 | } | |
b4b33636 | 263 | |
1ac534e9 AW |
264 | vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0), |
265 | indices_gc_hint); | |
b4b33636 | 266 | |
1ac534e9 AW |
267 | for (k = 0; k <= kmax; k++) |
268 | vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd; | |
269 | k = kmax; | |
270 | do | |
271 | { | |
272 | if (k == kmax) | |
273 | { | |
274 | SCM y = lra; | |
275 | SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds); | |
2a8688a9 | 276 | for (z = lvra; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y)) |
1ac534e9 AW |
277 | SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds); |
278 | if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) | |
279 | return 0; | |
280 | k--; | |
281 | continue; | |
282 | } | |
283 | if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd) | |
284 | { | |
285 | vinds[k]++; | |
286 | k++; | |
287 | continue; | |
288 | } | |
289 | vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1; | |
290 | k--; | |
291 | } | |
292 | while (k >= 0); | |
b4b33636 | 293 | |
8269f0be | 294 | case 5: |
1ac534e9 | 295 | return 1; |
0f2d19dd JB |
296 | } |
297 | } | |
298 | ||
ab1ca179 DL |
299 | static int |
300 | rafill (SCM dst, SCM fill) | |
301 | { | |
302 | long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1); | |
303 | scm_t_array_handle h; | |
304 | size_t i; | |
305 | ssize_t inc; | |
48ffc52c | 306 | scm_array_get_handle (SCM_I_ARRAY_V (dst), &h); |
13af75bf DL |
307 | i = SCM_I_ARRAY_BASE (dst); |
308 | inc = SCM_I_ARRAY_DIMS (dst)->inc; | |
ab1ca179 DL |
309 | |
310 | for (; n-- > 0; i += inc) | |
cf64dca6 | 311 | h.vset (h.vector, i, fill); |
ab1ca179 DL |
312 | |
313 | scm_array_handle_release (&h); | |
314 | return 1; | |
315 | } | |
0f2d19dd | 316 | |
3b3b36dd | 317 | SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, |
c209c88e | 318 | (SCM ra, SCM fill), |
b7e64f8b BT |
319 | "Store @var{fill} in every element of array @var{ra}. The value\n" |
320 | "returned is unspecified.") | |
1bbd0b84 | 321 | #define FUNC_NAME s_scm_array_fill_x |
ad310508 | 322 | { |
ab1ca179 | 323 | scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME); |
ad310508 MD |
324 | return SCM_UNSPECIFIED; |
325 | } | |
1bbd0b84 | 326 | #undef FUNC_NAME |
ad310508 | 327 | |
0f2d19dd | 328 | |
2c001086 DL |
329 | /* FIXME src-dst is the wrong order for scm_ra_matchp, but scm_ramapc |
330 | doesn't send SCM_I_ARRAYP for both src and dst, and this segfaults | |
331 | with the 'right' order. */ | |
72e2b592 | 332 | static int |
1bbd0b84 | 333 | racp (SCM src, SCM dst) |
0f2d19dd | 334 | { |
04b87de5 | 335 | long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1); |
72e2b592 DL |
336 | scm_t_array_handle h_s, h_d; |
337 | size_t i_s, i_d; | |
338 | ssize_t inc_s, inc_d; | |
339 | ||
0f2d19dd | 340 | dst = SCM_CAR (dst); |
13af75bf DL |
341 | i_s = SCM_I_ARRAY_BASE (src); |
342 | i_d = SCM_I_ARRAY_BASE (dst); | |
343 | inc_s = SCM_I_ARRAY_DIMS (src)->inc; | |
344 | inc_d = SCM_I_ARRAY_DIMS (dst)->inc; | |
c209c88e | 345 | |
2c001086 DL |
346 | scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s); |
347 | scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d); | |
348 | ||
349 | if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM | |
350 | && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) | |
351 | { | |
352 | SCM const * el_s = h_s.elements; | |
353 | SCM * el_d = h_d.writable_elements; | |
354 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) | |
355 | el_d[i_d] = el_s[i_s]; | |
356 | } | |
357 | else | |
358 | for (; n-- > 0; i_s += inc_s, i_d += inc_d) | |
359 | h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s)); | |
72e2b592 DL |
360 | |
361 | scm_array_handle_release (&h_d); | |
362 | scm_array_handle_release (&h_s); | |
363 | ||
0f2d19dd JB |
364 | return 1; |
365 | } | |
366 | ||
1bbd0b84 | 367 | SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x); |
1cc91f1b | 368 | |
1bbd0b84 | 369 | |
3b3b36dd | 370 | SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, |
c209c88e | 371 | (SCM src, SCM dst), |
8f85c0c6 | 372 | "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n" |
b7e64f8b BT |
373 | "Copy every element from vector or array @var{src} to the\n" |
374 | "corresponding element of @var{dst}. @var{dst} must have the\n" | |
375 | "same rank as @var{src}, and be at least as large in each\n" | |
b380b885 | 376 | "dimension. The order is unspecified.") |
1bbd0b84 | 377 | #define FUNC_NAME s_scm_array_copy_x |
0f2d19dd | 378 | { |
c209c88e | 379 | scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME); |
0f2d19dd JB |
380 | return SCM_UNSPECIFIED; |
381 | } | |
1bbd0b84 | 382 | #undef FUNC_NAME |
0f2d19dd | 383 | |
0f2d19dd | 384 | |
75a1b26c | 385 | #if SCM_ENABLE_DEPRECATED == 1 |
1cc91f1b | 386 | |
d09b201d DL |
387 | /* to be used as cproc in scm_ramapc to fill an array dimension with |
388 | "fill". */ | |
389 | int | |
390 | scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) | |
391 | { | |
392 | unsigned long i; | |
393 | unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1; | |
394 | long inc = SCM_I_ARRAY_DIMS (ra)->inc; | |
395 | unsigned long base = SCM_I_ARRAY_BASE (ra); | |
396 | ||
397 | ra = SCM_I_ARRAY_V (ra); | |
398 | ||
399 | for (i = base; n--; i += inc) | |
5e8c9d4a | 400 | ASET (ra, i, fill); |
d09b201d DL |
401 | |
402 | return 1; | |
403 | } | |
404 | ||
405 | /* Functions callable by ARRAY-MAP! */ | |
1cc91f1b | 406 | |
0f2d19dd | 407 | int |
1bbd0b84 | 408 | scm_ra_eqp (SCM ra0, SCM ras) |
0f2d19dd JB |
409 | { |
410 | SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); | |
fab07c30 MV |
411 | scm_t_array_handle ra0_handle; |
412 | scm_t_array_dim *ra0_dims; | |
413 | size_t n; | |
414 | ssize_t inc0; | |
415 | size_t i0 = 0; | |
416 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); | |
04b87de5 MV |
417 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
418 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
04b87de5 MV |
419 | ra1 = SCM_I_ARRAY_V (ra1); |
420 | ra2 = SCM_I_ARRAY_V (ra2); | |
fab07c30 MV |
421 | |
422 | scm_array_get_handle (ra0, &ra0_handle); | |
423 | ra0_dims = scm_array_handle_dims (&ra0_handle); | |
424 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; | |
425 | inc0 = ra0_dims[0].inc; | |
426 | ||
399aba0a | 427 | { |
399aba0a | 428 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
fab07c30 | 429 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
5e8c9d4a | 430 | if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2))) |
fab07c30 | 431 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
399aba0a MV |
432 | } |
433 | ||
fab07c30 | 434 | scm_array_handle_release (&ra0_handle); |
0f2d19dd JB |
435 | return 1; |
436 | } | |
437 | ||
438 | /* opt 0 means <, nonzero means >= */ | |
1cc91f1b | 439 | |
0f2d19dd | 440 | static int |
34d19ef6 | 441 | ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) |
0f2d19dd | 442 | { |
fab07c30 MV |
443 | scm_t_array_handle ra0_handle; |
444 | scm_t_array_dim *ra0_dims; | |
445 | size_t n; | |
446 | ssize_t inc0; | |
447 | size_t i0 = 0; | |
448 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); | |
04b87de5 MV |
449 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; |
450 | long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
04b87de5 MV |
451 | ra1 = SCM_I_ARRAY_V (ra1); |
452 | ra2 = SCM_I_ARRAY_V (ra2); | |
399aba0a | 453 | |
fab07c30 MV |
454 | scm_array_get_handle (ra0, &ra0_handle); |
455 | ra0_dims = scm_array_handle_dims (&ra0_handle); | |
456 | n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; | |
457 | inc0 = ra0_dims[0].inc; | |
458 | ||
399aba0a | 459 | { |
399aba0a | 460 | for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) |
fab07c30 | 461 | if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) |
399aba0a | 462 | if (opt ? |
5e8c9d4a DL |
463 | scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) : |
464 | scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2)))) | |
fab07c30 | 465 | scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); |
399aba0a MV |
466 | } |
467 | ||
fab07c30 | 468 | scm_array_handle_release (&ra0_handle); |
0f2d19dd JB |
469 | return 1; |
470 | } | |
471 | ||
472 | ||
1cc91f1b | 473 | |
0f2d19dd | 474 | int |
1bbd0b84 | 475 | scm_ra_lessp (SCM ra0, SCM ras) |
0f2d19dd JB |
476 | { |
477 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); | |
478 | } | |
479 | ||
1cc91f1b | 480 | |
0f2d19dd | 481 | int |
1bbd0b84 | 482 | scm_ra_leqp (SCM ra0, SCM ras) |
0f2d19dd JB |
483 | { |
484 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); | |
485 | } | |
486 | ||
1cc91f1b | 487 | |
0f2d19dd | 488 | int |
1bbd0b84 | 489 | scm_ra_grp (SCM ra0, SCM ras) |
0f2d19dd JB |
490 | { |
491 | return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); | |
492 | } | |
493 | ||
1cc91f1b | 494 | |
0f2d19dd | 495 | int |
1bbd0b84 | 496 | scm_ra_greqp (SCM ra0, SCM ras) |
0f2d19dd JB |
497 | { |
498 | return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); | |
499 | } | |
500 | ||
501 | ||
0f2d19dd | 502 | int |
1bbd0b84 | 503 | scm_ra_sum (SCM ra0, SCM ras) |
0f2d19dd | 504 | { |
04b87de5 MV |
505 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
506 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
507 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
508 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 509 | if (!scm_is_null(ras)) |
c209c88e GB |
510 | { |
511 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
512 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
513 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
514 | ra1 = SCM_I_ARRAY_V (ra1); | |
c209c88e GB |
515 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
516 | { | |
517 | default: | |
0f2d19dd | 518 | { |
c209c88e | 519 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 520 | ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1))); |
c209c88e GB |
521 | break; |
522 | } | |
c209c88e GB |
523 | } |
524 | } | |
0f2d19dd JB |
525 | return 1; |
526 | } | |
527 | ||
528 | ||
1cc91f1b | 529 | |
0f2d19dd | 530 | int |
1bbd0b84 | 531 | scm_ra_difference (SCM ra0, SCM ras) |
0f2d19dd | 532 | { |
04b87de5 MV |
533 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
534 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
535 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
536 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 537 | if (scm_is_null (ras)) |
c209c88e GB |
538 | { |
539 | switch (SCM_TYP7 (ra0)) | |
540 | { | |
541 | default: | |
542 | { | |
c209c88e | 543 | for (; n-- > 0; i0 += inc0) |
5e8c9d4a | 544 | ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED)); |
c209c88e GB |
545 | break; |
546 | } | |
c209c88e GB |
547 | } |
548 | } | |
0f2d19dd JB |
549 | else |
550 | { | |
551 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
552 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
553 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
554 | ra1 = SCM_I_ARRAY_V (ra1); | |
0f2d19dd JB |
555 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
556 | { | |
557 | default: | |
558 | { | |
0f2d19dd | 559 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 560 | ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1))); |
0f2d19dd JB |
561 | break; |
562 | } | |
0f2d19dd JB |
563 | } |
564 | } | |
565 | return 1; | |
566 | } | |
567 | ||
568 | ||
1cc91f1b | 569 | |
0f2d19dd | 570 | int |
1bbd0b84 | 571 | scm_ra_product (SCM ra0, SCM ras) |
0f2d19dd | 572 | { |
04b87de5 MV |
573 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
574 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
575 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
576 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 577 | if (!scm_is_null (ras)) |
c209c88e GB |
578 | { |
579 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
580 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
581 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
582 | ra1 = SCM_I_ARRAY_V (ra1); | |
c209c88e GB |
583 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
584 | { | |
585 | default: | |
0f2d19dd | 586 | { |
c209c88e | 587 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
5e8c9d4a | 588 | ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1))); |
c209c88e | 589 | } |
c209c88e GB |
590 | } |
591 | } | |
0f2d19dd JB |
592 | return 1; |
593 | } | |
594 | ||
1cc91f1b | 595 | |
0f2d19dd | 596 | int |
1bbd0b84 | 597 | scm_ra_divide (SCM ra0, SCM ras) |
0f2d19dd | 598 | { |
04b87de5 MV |
599 | long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; |
600 | unsigned long i0 = SCM_I_ARRAY_BASE (ra0); | |
601 | long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
602 | ra0 = SCM_I_ARRAY_V (ra0); | |
d2e53ed6 | 603 | if (scm_is_null (ras)) |
c209c88e GB |
604 | { |
605 | switch (SCM_TYP7 (ra0)) | |
606 | { | |
607 | default: | |
608 | { | |
c209c88e | 609 | for (; n-- > 0; i0 += inc0) |
5e8c9d4a | 610 | ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED)); |
c209c88e GB |
611 | break; |
612 | } | |
c209c88e GB |
613 | } |
614 | } | |
0f2d19dd JB |
615 | else |
616 | { | |
617 | SCM ra1 = SCM_CAR (ras); | |
04b87de5 MV |
618 | unsigned long i1 = SCM_I_ARRAY_BASE (ra1); |
619 | long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
620 | ra1 = SCM_I_ARRAY_V (ra1); | |
0f2d19dd JB |
621 | switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) |
622 | { | |
623 | default: | |
624 | { | |
0f2d19dd | 625 | for (; n-- > 0; i0 += inc0, i1 += inc1) |
afaf9d0b | 626 | { |
5e8c9d4a DL |
627 | SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1)); |
628 | ASET (ra0, i0, res); | |
afaf9d0b | 629 | } |
0f2d19dd JB |
630 | break; |
631 | } | |
0f2d19dd JB |
632 | } |
633 | } | |
634 | return 1; | |
635 | } | |
636 | ||
1cc91f1b | 637 | |
0f2d19dd | 638 | int |
1bbd0b84 | 639 | scm_array_identity (SCM dst, SCM src) |
0f2d19dd JB |
640 | { |
641 | return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); | |
642 | } | |
643 | ||
75a1b26c | 644 | #endif /* SCM_ENABLE_DEPRECATED */ |
0f2d19dd | 645 | |
75a1b26c | 646 | static int |
34d19ef6 | 647 | ramap (SCM ra0, SCM proc, SCM ras) |
0f2d19dd | 648 | { |
9a68d7b3 | 649 | ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
51a1763f | 650 | size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; |
9a68d7b3 | 651 | |
51a1763f DL |
652 | scm_t_array_handle h0; |
653 | size_t i0, i0end; | |
654 | ssize_t inc0; | |
48ffc52c | 655 | scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0); |
13af75bf DL |
656 | i0 = SCM_I_ARRAY_BASE (ra0); |
657 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
51a1763f | 658 | i0end = i0 + n*inc0; |
d2e53ed6 | 659 | if (scm_is_null (ras)) |
9a68d7b3 | 660 | for (; i0 < i0end; i0 += inc0) |
cf64dca6 | 661 | h0.vset (h0.vector, i0, scm_call_0 (proc)); |
0f2d19dd JB |
662 | else |
663 | { | |
664 | SCM ra1 = SCM_CAR (ras); | |
51a1763f DL |
665 | scm_t_array_handle h1; |
666 | size_t i1; | |
667 | ssize_t inc1; | |
48ffc52c | 668 | scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1); |
13af75bf DL |
669 | i1 = SCM_I_ARRAY_BASE (ra1); |
670 | inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; | |
9a68d7b3 | 671 | ras = SCM_CDR (ras); |
51a1763f | 672 | if (scm_is_null (ras)) |
9a68d7b3 | 673 | for (; i0 < i0end; i0 += inc0, i1 += inc1) |
cf64dca6 | 674 | h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); |
9a68d7b3 DL |
675 | else |
676 | { | |
677 | ras = scm_vector (ras); | |
678 | for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i) | |
679 | { | |
680 | SCM args = SCM_EOL; | |
681 | unsigned long k; | |
682 | for (k = scm_c_vector_length (ras); k--;) | |
5e8c9d4a | 683 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
cf64dca6 AW |
684 | h0.vset (h0.vector, i0, |
685 | scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); | |
9a68d7b3 DL |
686 | } |
687 | } | |
51a1763f | 688 | scm_array_handle_release (&h1); |
0f2d19dd | 689 | } |
51a1763f | 690 | scm_array_handle_release (&h0); |
0f2d19dd JB |
691 | return 1; |
692 | } | |
693 | ||
1cc91f1b | 694 | |
1bbd0b84 | 695 | SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x); |
1cc91f1b | 696 | |
718866aa | 697 | SCM_SYMBOL (sym_b, "b"); |
1bbd0b84 | 698 | |
3b3b36dd | 699 | SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, |
c209c88e | 700 | (SCM ra0, SCM proc, SCM lra), |
8f85c0c6 | 701 | "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n" |
b7e64f8b BT |
702 | "@var{array1}, @dots{} must have the same number of dimensions\n" |
703 | "as @var{ra0} and have a range for each index which includes the\n" | |
704 | "range for the corresponding index in @var{ra0}. @var{proc} is\n" | |
705 | "applied to each tuple of elements of @var{array1}, @dots{} and\n" | |
706 | "the result is stored as the corresponding element in @var{ra0}.\n" | |
707 | "The value returned is unspecified. The order of application is\n" | |
708 | "unspecified.") | |
1bbd0b84 | 709 | #define FUNC_NAME s_scm_array_map_x |
0f2d19dd | 710 | { |
34d19ef6 | 711 | SCM_VALIDATE_PROC (2, proc); |
af45e3b0 | 712 | SCM_VALIDATE_REST_ARGUMENT (lra); |
f530e94f | 713 | |
31d845b4 AW |
714 | scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); |
715 | return SCM_UNSPECIFIED; | |
0f2d19dd | 716 | } |
1bbd0b84 | 717 | #undef FUNC_NAME |
0f2d19dd | 718 | |
1cc91f1b | 719 | |
0f2d19dd | 720 | static int |
34d19ef6 | 721 | rafe (SCM ra0, SCM proc, SCM ras) |
0f2d19dd | 722 | { |
c3e3ef6e DL |
723 | ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; |
724 | size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; | |
725 | ||
726 | scm_t_array_handle h0; | |
727 | size_t i0, i0end; | |
728 | ssize_t inc0; | |
48ffc52c | 729 | scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0); |
13af75bf DL |
730 | i0 = SCM_I_ARRAY_BASE (ra0); |
731 | inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; | |
c3e3ef6e | 732 | i0end = i0 + n*inc0; |
d2e53ed6 | 733 | if (scm_is_null (ras)) |
c3e3ef6e | 734 | for (; i0 < i0end; i0 += inc0) |
cf64dca6 | 735 | scm_call_1 (proc, h0.vref (h0.vector, i0)); |
0f2d19dd JB |
736 | else |
737 | { | |
c3e3ef6e DL |
738 | ras = scm_vector (ras); |
739 | for (; i0 < i0end; i0 += inc0, ++i) | |
740 | { | |
741 | SCM args = SCM_EOL; | |
742 | unsigned long k; | |
743 | for (k = scm_c_vector_length (ras); k--;) | |
5e8c9d4a | 744 | args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); |
cf64dca6 | 745 | scm_apply_1 (proc, h0.vref (h0.vector, i0), args); |
c3e3ef6e | 746 | } |
0f2d19dd | 747 | } |
c3e3ef6e | 748 | scm_array_handle_release (&h0); |
0f2d19dd JB |
749 | return 1; |
750 | } | |
751 | ||
3b3b36dd | 752 | SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, |
c209c88e | 753 | (SCM proc, SCM ra0, SCM lra), |
b7e64f8b | 754 | "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n" |
b380b885 | 755 | "in row-major order. The value returned is unspecified.") |
1bbd0b84 | 756 | #define FUNC_NAME s_scm_array_for_each |
0f2d19dd | 757 | { |
34d19ef6 | 758 | SCM_VALIDATE_PROC (1, proc); |
af45e3b0 | 759 | SCM_VALIDATE_REST_ARGUMENT (lra); |
c209c88e | 760 | scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME); |
0f2d19dd JB |
761 | return SCM_UNSPECIFIED; |
762 | } | |
1bbd0b84 | 763 | #undef FUNC_NAME |
0f2d19dd | 764 | |
828ada13 | 765 | static void |
f0521cda AW |
766 | array_index_map_1 (SCM ra, SCM proc) |
767 | { | |
828ada13 AW |
768 | scm_t_array_handle h; |
769 | ssize_t i, inc; | |
770 | size_t p; | |
828ada13 | 771 | scm_array_get_handle (ra, &h); |
828ada13 AW |
772 | inc = h.dims[0].inc; |
773 | for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc) | |
cf64dca6 | 774 | h.vset (h.vector, p, scm_call_1 (proc, scm_from_ulong (i))); |
828ada13 | 775 | scm_array_handle_release (&h); |
f0521cda AW |
776 | } |
777 | ||
778 | /* Here we assume that the array is a scm_tc7_array, as that is the only | |
779 | kind of array in Guile that supports rank > 1. */ | |
828ada13 | 780 | static void |
f0521cda AW |
781 | array_index_map_n (SCM ra, SCM proc) |
782 | { | |
828ada13 | 783 | size_t i; |
f0521cda AW |
784 | SCM args = SCM_EOL; |
785 | int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1; | |
f0521cda AW |
786 | long *vinds; |
787 | ||
788 | vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra), | |
789 | indices_gc_hint); | |
790 | ||
791 | for (k = 0; k <= kmax; k++) | |
b0d9b074 DL |
792 | { |
793 | vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd; | |
794 | if (vinds[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd) | |
795 | return; | |
796 | } | |
f0521cda AW |
797 | k = kmax; |
798 | do | |
799 | { | |
800 | if (k == kmax) | |
801 | { | |
802 | vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd; | |
803 | i = cind (ra, vinds); | |
804 | for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) | |
805 | { | |
806 | for (j = kmax + 1, args = SCM_EOL; j--;) | |
807 | args = scm_cons (scm_from_long (vinds[j]), args); | |
808 | ASET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args)); | |
809 | i += SCM_I_ARRAY_DIMS (ra)[k].inc; | |
810 | } | |
811 | k--; | |
f0521cda | 812 | } |
b0d9b074 | 813 | else if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd) |
f0521cda AW |
814 | { |
815 | vinds[k]++; | |
816 | k++; | |
f0521cda | 817 | } |
b0d9b074 DL |
818 | else |
819 | { | |
820 | vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1; | |
821 | k--; | |
822 | } | |
f0521cda AW |
823 | } |
824 | while (k >= 0); | |
f0521cda AW |
825 | } |
826 | ||
3b3b36dd | 827 | SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, |
c209c88e | 828 | (SCM ra, SCM proc), |
b7e64f8b | 829 | "Apply @var{proc} to the indices of each element of @var{ra} in\n" |
b380b885 MD |
830 | "turn, storing the result in the corresponding element. The value\n" |
831 | "returned and the order of application are unspecified.\n\n" | |
832 | "One can implement @var{array-indexes} as\n" | |
1e6808ea | 833 | "@lisp\n" |
b380b885 MD |
834 | "(define (array-indexes array)\n" |
835 | " (let ((ra (apply make-array #f (array-shape array))))\n" | |
836 | " (array-index-map! ra (lambda x x))\n" | |
837 | " ra))\n" | |
1e6808ea | 838 | "@end lisp\n" |
b380b885 | 839 | "Another example:\n" |
1e6808ea | 840 | "@lisp\n" |
b380b885 MD |
841 | "(define (apl:index-generator n)\n" |
842 | " (let ((v (make-uniform-vector n 1)))\n" | |
843 | " (array-index-map! v (lambda (i) i))\n" | |
844 | " v))\n" | |
1e6808ea | 845 | "@end lisp") |
1bbd0b84 | 846 | #define FUNC_NAME s_scm_array_index_map_x |
0f2d19dd | 847 | { |
34d19ef6 | 848 | SCM_VALIDATE_PROC (2, proc); |
399aba0a | 849 | |
f0521cda | 850 | switch (scm_c_array_rank (ra)) |
16259ae3 | 851 | { |
f0521cda AW |
852 | case 0: |
853 | scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL); | |
854 | break; | |
855 | case 1: | |
856 | array_index_map_1 (ra, proc); | |
857 | break; | |
858 | default: | |
859 | array_index_map_n (ra, proc); | |
860 | break; | |
16259ae3 | 861 | } |
b4b33636 | 862 | |
f0521cda | 863 | return SCM_UNSPECIFIED; |
0f2d19dd | 864 | } |
1bbd0b84 | 865 | #undef FUNC_NAME |
0f2d19dd | 866 | |
1cc91f1b | 867 | |
0f2d19dd | 868 | static int |
a587d6a9 AW |
869 | array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy, |
870 | size_t dim, unsigned long posx, unsigned long posy) | |
0f2d19dd | 871 | { |
a587d6a9 AW |
872 | if (dim == scm_array_handle_rank (hx)) |
873 | return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx), | |
874 | scm_array_handle_ref (hy, posy))); | |
e466c6a2 | 875 | else |
c209c88e | 876 | { |
a587d6a9 AW |
877 | long incx, incy; |
878 | size_t i; | |
399aba0a | 879 | |
a587d6a9 AW |
880 | if (hx->dims[dim].lbnd != hy->dims[dim].lbnd |
881 | || hx->dims[dim].ubnd != hy->dims[dim].ubnd) | |
882 | return 0; | |
883 | ||
884 | i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1; | |
885 | ||
886 | incx = hx->dims[dim].inc; | |
887 | incy = hy->dims[dim].inc; | |
888 | posx += (i - 1) * incx; | |
889 | posy += (i - 1) * incy; | |
890 | ||
891 | for (; i > 0; i--, posx -= incx, posy -= incy) | |
892 | if (!array_compare (hx, hy, dim + 1, posx, posy)) | |
893 | return 0; | |
c209c88e | 894 | return 1; |
c209c88e | 895 | } |
0f2d19dd JB |
896 | } |
897 | ||
a587d6a9 AW |
898 | SCM |
899 | scm_array_equal_p (SCM x, SCM y) | |
0f2d19dd | 900 | { |
a587d6a9 AW |
901 | scm_t_array_handle hx, hy; |
902 | SCM res; | |
903 | ||
904 | scm_array_get_handle (x, &hx); | |
905 | scm_array_get_handle (y, &hy); | |
906 | ||
907 | res = scm_from_bool (hx.ndims == hy.ndims | |
908 | && hx.element_type == hy.element_type); | |
3ffd1ba9 | 909 | |
a587d6a9 AW |
910 | if (scm_is_true (res)) |
911 | res = scm_from_bool (array_compare (&hx, &hy, 0, 0, 0)); | |
0f2d19dd | 912 | |
a587d6a9 AW |
913 | scm_array_handle_release (&hy); |
914 | scm_array_handle_release (&hx); | |
1cc91f1b | 915 | |
a587d6a9 | 916 | return res; |
0f2d19dd JB |
917 | } |
918 | ||
f1d19308 | 919 | static SCM scm_i_array_equal_p (SCM, SCM, SCM); |
31d845b4 AW |
920 | SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, |
921 | (SCM ra0, SCM ra1, SCM rest), | |
1e6808ea MG |
922 | "Return @code{#t} iff all arguments are arrays with the same\n" |
923 | "shape, the same type, and have corresponding elements which are\n" | |
924 | "either @code{equal?} or @code{array-equal?}. This function\n" | |
a587d6a9 | 925 | "differs from @code{equal?} in that all arguments must be arrays.") |
31d845b4 AW |
926 | #define FUNC_NAME s_scm_i_array_equal_p |
927 | { | |
928 | if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1)) | |
929 | return SCM_BOOL_T; | |
930 | ||
931 | while (!scm_is_null (rest)) | |
8a1f4f98 | 932 | { if (scm_is_false (scm_array_equal_p (ra0, ra1))) |
31d845b4 | 933 | return SCM_BOOL_F; |
8a1f4f98 AW |
934 | ra0 = ra1; |
935 | ra1 = scm_car (rest); | |
31d845b4 AW |
936 | rest = scm_cdr (rest); |
937 | } | |
938 | return scm_array_equal_p (ra0, ra1); | |
0f981281 | 939 | } |
4079f87e | 940 | #undef FUNC_NAME |
0f2d19dd | 941 | |
1cc91f1b | 942 | |
0f2d19dd | 943 | void |
5d1b3b2d | 944 | scm_init_array_map (void) |
0f2d19dd | 945 | { |
5d1b3b2d | 946 | #include "libguile/array-map.x" |
1bbd0b84 | 947 | scm_add_feature (s_scm_array_for_each); |
0f2d19dd | 948 | } |
89e00824 ML |
949 | |
950 | /* | |
951 | Local Variables: | |
952 | c-file-style: "gnu" | |
953 | End: | |
954 | */ |