Commit | Line | Data |
---|---|---|
493ceb99 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, |
eb3d623d DL |
2 | * 2006, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, |
3 | * Inc. | |
65704b98 | 4 | * |
73be1d9e | 5 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
6 | * modify it under the terms of the GNU Lesser General Public License |
7 | * as published by the Free Software Foundation; either version 3 of | |
8 | * the License, or (at your option) any later version. | |
0f2d19dd | 9 | * |
53befeb7 NJ |
10 | * This library is distributed in the hope that it will be useful, but |
11 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | * Lesser General Public License for more details. | |
0f2d19dd | 14 | * |
73be1d9e MV |
15 | * You should have received a copy of the GNU Lesser General Public |
16 | * License along with this library; if not, write to the Free Software | |
53befeb7 NJ |
17 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
18 | * 02110-1301 USA | |
73be1d9e | 19 | */ |
1bbd0b84 | 20 | |
1bbd0b84 | 21 | |
0f2d19dd JB |
22 | \f |
23 | ||
dbb605f5 | 24 | #ifdef HAVE_CONFIG_H |
2a5cd898 RB |
25 | # include <config.h> |
26 | #endif | |
27 | ||
0f2d19dd | 28 | #include <stdio.h> |
e6e2e95a | 29 | #include <errno.h> |
783e7774 | 30 | #include <string.h> |
13af75bf | 31 | #include <assert.h> |
e6e2e95a | 32 | |
65704b98 DL |
33 | #include "verify.h" |
34 | ||
a0599745 | 35 | #include "libguile/_scm.h" |
e0e49670 MV |
36 | #include "libguile/__scm.h" |
37 | #include "libguile/eq.h" | |
a0599745 MD |
38 | #include "libguile/chars.h" |
39 | #include "libguile/eval.h" | |
40 | #include "libguile/fports.h" | |
a0599745 MD |
41 | #include "libguile/feature.h" |
42 | #include "libguile/root.h" | |
43 | #include "libguile/strings.h" | |
c44ca4fe | 44 | #include "libguile/srfi-13.h" |
e0e49670 | 45 | #include "libguile/srfi-4.h" |
a0599745 | 46 | #include "libguile/vectors.h" |
cf396142 | 47 | #include "libguile/bitvectors.h" |
438974d0 | 48 | #include "libguile/bytevectors.h" |
bfad4005 | 49 | #include "libguile/list.h" |
d44ff083 | 50 | #include "libguile/dynwind.h" |
943a0a87 | 51 | #include "libguile/read.h" |
a0599745 MD |
52 | |
53 | #include "libguile/validate.h" | |
2fa901a5 | 54 | #include "libguile/arrays.h" |
943a0a87 | 55 | #include "libguile/array-map.h" |
f332e957 | 56 | #include "libguile/generalized-vectors.h" |
943a0a87 | 57 | #include "libguile/generalized-arrays.h" |
476b894c | 58 | #include "libguile/uniform.h" |
0f2d19dd | 59 | |
0f2d19dd | 60 | |
04b87de5 | 61 | #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ |
b2637c98 | 62 | (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) |
04b87de5 | 63 | #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ |
b2637c98 | 64 | (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) |
1cc91f1b | 65 | |
0f2d19dd | 66 | |
c2cb82f8 | 67 | SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, |
e2d37336 MD |
68 | (SCM ra), |
69 | "Return the root vector of a shared array.") | |
70 | #define FUNC_NAME s_scm_shared_array_root | |
71 | { | |
1e2a55e4 | 72 | if (SCM_I_ARRAYP (ra)) |
04b87de5 | 73 | return SCM_I_ARRAY_V (ra); |
1e2a55e4 DL |
74 | else if (!scm_is_array (ra)) |
75 | scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); | |
c2cb82f8 | 76 | else |
52372719 | 77 | return ra; |
e2d37336 MD |
78 | } |
79 | #undef FUNC_NAME | |
80 | ||
81 | ||
c2cb82f8 | 82 | SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, |
e2d37336 MD |
83 | (SCM ra), |
84 | "Return the root vector index of the first element in the array.") | |
85 | #define FUNC_NAME s_scm_shared_array_offset | |
86 | { | |
52372719 MV |
87 | scm_t_array_handle handle; |
88 | SCM res; | |
89 | ||
90 | scm_array_get_handle (ra, &handle); | |
91 | res = scm_from_size_t (handle.base); | |
92 | scm_array_handle_release (&handle); | |
93 | return res; | |
e2d37336 MD |
94 | } |
95 | #undef FUNC_NAME | |
96 | ||
97 | ||
65704b98 | 98 | SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, |
e2d37336 MD |
99 | (SCM ra), |
100 | "For each dimension, return the distance between elements in the root vector.") | |
101 | #define FUNC_NAME s_scm_shared_array_increments | |
102 | { | |
52372719 | 103 | scm_t_array_handle handle; |
e2d37336 | 104 | SCM res = SCM_EOL; |
1be6b49c | 105 | size_t k; |
92c2555f | 106 | scm_t_array_dim *s; |
02339e5b | 107 | |
52372719 MV |
108 | scm_array_get_handle (ra, &handle); |
109 | k = scm_array_handle_rank (&handle); | |
110 | s = scm_array_handle_dims (&handle); | |
e2d37336 | 111 | while (k--) |
52372719 MV |
112 | res = scm_cons (scm_from_ssize_t (s[k].inc), res); |
113 | scm_array_handle_release (&handle); | |
e2d37336 MD |
114 | return res; |
115 | } | |
116 | #undef FUNC_NAME | |
117 | ||
65704b98 DL |
118 | /* FIXME: to avoid this assumption, fix the accessors in arrays.h, |
119 | scm_i_make_array, and the array cases in system/vm/assembler.scm. */ | |
120 | ||
121 | verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits)); | |
122 | ||
123 | /* Matching SCM_I_ARRAY accessors in arrays.h */ | |
67543d07 | 124 | SCM |
66b9d7d3 | 125 | scm_i_make_array (int ndim) |
0f2d19dd | 126 | { |
65704b98 DL |
127 | SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); |
128 | SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F); | |
129 | SCM_I_ARRAY_SET_BASE (ra, 0); | |
130 | /* dimensions are unset */ | |
0f2d19dd JB |
131 | return ra; |
132 | } | |
133 | ||
134 | static char s_bad_spec[] = "Bad scm_array dimension"; | |
0f2d19dd | 135 | |
1cc91f1b | 136 | |
02339e5b MV |
137 | /* Increments will still need to be set. */ |
138 | ||
1e2a55e4 | 139 | static SCM |
0cd6cb2f | 140 | scm_i_shap2ra (SCM args) |
0f2d19dd | 141 | { |
92c2555f | 142 | scm_t_array_dim *s; |
1e2a55e4 | 143 | SCM ra, spec; |
0f2d19dd | 144 | int ndim = scm_ilength (args); |
b3fcac34 | 145 | if (ndim < 0) |
0cd6cb2f | 146 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
b3fcac34 | 147 | |
66b9d7d3 | 148 | ra = scm_i_make_array (ndim); |
65704b98 | 149 | SCM_I_ARRAY_SET_BASE (ra, 0); |
04b87de5 | 150 | s = SCM_I_ARRAY_DIMS (ra); |
d2e53ed6 | 151 | for (; !scm_is_null (args); s++, args = SCM_CDR (args)) |
0f2d19dd JB |
152 | { |
153 | spec = SCM_CAR (args); | |
e11e83f3 | 154 | if (scm_is_integer (spec)) |
0f2d19dd | 155 | { |
0f2d19dd | 156 | s->lbnd = 0; |
1e2a55e4 DL |
157 | s->ubnd = scm_to_ssize_t (spec); |
158 | if (s->ubnd < 0) | |
159 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); | |
160 | --s->ubnd; | |
0f2d19dd JB |
161 | } |
162 | else | |
163 | { | |
d2e53ed6 | 164 | if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) |
0cd6cb2f | 165 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
1e2a55e4 DL |
166 | s->lbnd = scm_to_ssize_t (SCM_CAR (spec)); |
167 | spec = SCM_CDR (spec); | |
168 | if (!scm_is_pair (spec) | |
169 | || !scm_is_integer (SCM_CAR (spec)) | |
170 | || !scm_is_null (SCM_CDR (spec))) | |
0cd6cb2f | 171 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
1e2a55e4 DL |
172 | s->ubnd = scm_to_ssize_t (SCM_CAR (spec)); |
173 | if (s->ubnd - s->lbnd < -1) | |
174 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); | |
0f2d19dd | 175 | } |
1e2a55e4 | 176 | s->inc = 1; |
0f2d19dd JB |
177 | } |
178 | return ra; | |
179 | } | |
180 | ||
f301dbf3 MV |
181 | SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, |
182 | (SCM type, SCM fill, SCM bounds), | |
183 | "Create and return an array of type @var{type}.") | |
184 | #define FUNC_NAME s_scm_make_typed_array | |
0f2d19dd | 185 | { |
f301dbf3 | 186 | size_t k, rlen = 1; |
92c2555f | 187 | scm_t_array_dim *s; |
0f2d19dd | 188 | SCM ra; |
65704b98 | 189 | |
0cd6cb2f | 190 | ra = scm_i_shap2ra (bounds); |
e038c042 | 191 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); |
04b87de5 MV |
192 | s = SCM_I_ARRAY_DIMS (ra); |
193 | k = SCM_I_ARRAY_NDIM (ra); | |
1be6b49c | 194 | |
0f2d19dd JB |
195 | while (k--) |
196 | { | |
a3a32939 | 197 | s[k].inc = rlen; |
2caaadd1 | 198 | SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); |
0f2d19dd | 199 | rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; |
0f2d19dd | 200 | } |
a3a32939 | 201 | |
f0b91039 | 202 | if (scm_is_eq (fill, SCM_UNSPECIFIED)) |
f301dbf3 | 203 | fill = SCM_UNDEFINED; |
a3a32939 | 204 | |
65704b98 | 205 | SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill)); |
a3a32939 | 206 | |
04b87de5 | 207 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) |
2bee653a | 208 | if (0 == s->lbnd) |
04b87de5 | 209 | return SCM_I_ARRAY_V (ra); |
2bee653a | 210 | |
0f2d19dd JB |
211 | return ra; |
212 | } | |
1bbd0b84 | 213 | #undef FUNC_NAME |
0f2d19dd | 214 | |
782a82ee AW |
215 | SCM |
216 | scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, | |
217 | size_t byte_len) | |
218 | #define FUNC_NAME "scm_from_contiguous_typed_array" | |
219 | { | |
220 | size_t k, rlen = 1; | |
221 | scm_t_array_dim *s; | |
782a82ee AW |
222 | SCM ra; |
223 | scm_t_array_handle h; | |
f5a51cae | 224 | void *elts; |
782a82ee | 225 | size_t sz; |
65704b98 | 226 | |
782a82ee AW |
227 | ra = scm_i_shap2ra (bounds); |
228 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); | |
229 | s = SCM_I_ARRAY_DIMS (ra); | |
230 | k = SCM_I_ARRAY_NDIM (ra); | |
231 | ||
232 | while (k--) | |
233 | { | |
234 | s[k].inc = rlen; | |
235 | SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); | |
236 | rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; | |
237 | } | |
65704b98 | 238 | SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED)); |
782a82ee AW |
239 | |
240 | ||
241 | scm_array_get_handle (ra, &h); | |
f5a51cae AW |
242 | elts = h.writable_elements; |
243 | sz = scm_array_handle_uniform_element_bit_size (&h); | |
782a82ee AW |
244 | scm_array_handle_release (&h); |
245 | ||
f5a51cae AW |
246 | if (sz >= 8 && ((sz % 8) == 0)) |
247 | { | |
248 | if (byte_len % (sz / 8)) | |
249 | SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); | |
250 | if (byte_len / (sz / 8) != rlen) | |
251 | SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); | |
252 | } | |
b0fae4ec | 253 | else if (sz < 8) |
f5a51cae | 254 | { |
d65514a2 AW |
255 | /* Elements of sub-byte size (bitvectors) are addressed in 32-bit |
256 | units. */ | |
257 | if (byte_len != ((rlen * sz + 31) / 32) * 4) | |
f5a51cae AW |
258 | SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); |
259 | } | |
b0fae4ec AW |
260 | else |
261 | /* an internal guile error, really */ | |
262 | SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL); | |
782a82ee | 263 | |
f5a51cae | 264 | memcpy (elts, bytes, byte_len); |
782a82ee AW |
265 | |
266 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) | |
2bee653a | 267 | if (0 == s->lbnd) |
782a82ee AW |
268 | return SCM_I_ARRAY_V (ra); |
269 | return ra; | |
270 | } | |
271 | #undef FUNC_NAME | |
272 | ||
73788ca8 AW |
273 | SCM |
274 | scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) | |
275 | #define FUNC_NAME "scm_from_contiguous_array" | |
276 | { | |
277 | size_t k, rlen = 1; | |
278 | scm_t_array_dim *s; | |
279 | SCM ra; | |
280 | scm_t_array_handle h; | |
65704b98 | 281 | |
73788ca8 AW |
282 | ra = scm_i_shap2ra (bounds); |
283 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); | |
284 | s = SCM_I_ARRAY_DIMS (ra); | |
285 | k = SCM_I_ARRAY_NDIM (ra); | |
286 | ||
287 | while (k--) | |
288 | { | |
289 | s[k].inc = rlen; | |
290 | SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); | |
291 | rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; | |
292 | } | |
293 | if (rlen != len) | |
294 | SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL); | |
295 | ||
65704b98 | 296 | SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED)); |
73788ca8 AW |
297 | scm_array_get_handle (ra, &h); |
298 | memcpy (h.writable_elements, elts, rlen * sizeof(SCM)); | |
299 | scm_array_handle_release (&h); | |
300 | ||
301 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) | |
2bee653a | 302 | if (0 == s->lbnd) |
73788ca8 AW |
303 | return SCM_I_ARRAY_V (ra); |
304 | return ra; | |
305 | } | |
306 | #undef FUNC_NAME | |
307 | ||
f301dbf3 MV |
308 | SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, |
309 | (SCM fill, SCM bounds), | |
310 | "Create and return an array.") | |
311 | #define FUNC_NAME s_scm_make_array | |
312 | { | |
313 | return scm_make_typed_array (SCM_BOOL_T, fill, bounds); | |
314 | } | |
315 | #undef FUNC_NAME | |
316 | ||
1e2a55e4 | 317 | static void |
0cd6cb2f | 318 | scm_i_ra_set_contp (SCM ra) |
0f2d19dd | 319 | { |
04b87de5 | 320 | size_t k = SCM_I_ARRAY_NDIM (ra); |
0f2d19dd | 321 | if (k) |
0f2d19dd | 322 | { |
1e2a55e4 | 323 | ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; |
fe0c6dae | 324 | while (k--) |
0f2d19dd | 325 | { |
04b87de5 | 326 | if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) |
fe0c6dae | 327 | { |
e038c042 | 328 | SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); |
fe0c6dae JB |
329 | return; |
330 | } | |
65704b98 | 331 | inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd |
04b87de5 | 332 | - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); |
0f2d19dd | 333 | } |
0f2d19dd | 334 | } |
e038c042 | 335 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); |
0f2d19dd JB |
336 | } |
337 | ||
338 | ||
3b3b36dd | 339 | SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, |
1bbd0b84 | 340 | (SCM oldra, SCM mapfunc, SCM dims), |
b7e64f8b BT |
341 | "@code{make-shared-array} can be used to create shared subarrays\n" |
342 | "of other arrays. The @var{mapfunc} is a function that\n" | |
343 | "translates coordinates in the new array into coordinates in the\n" | |
344 | "old array. A @var{mapfunc} must be linear, and its range must\n" | |
345 | "stay within the bounds of the old array, but it can be\n" | |
346 | "otherwise arbitrary. A simple example:\n" | |
1e6808ea | 347 | "@lisp\n" |
b380b885 MD |
348 | "(define fred (make-array #f 8 8))\n" |
349 | "(define freds-diagonal\n" | |
350 | " (make-shared-array fred (lambda (i) (list i i)) 8))\n" | |
351 | "(array-set! freds-diagonal 'foo 3)\n" | |
352 | "(array-ref fred 3 3) @result{} foo\n" | |
353 | "(define freds-center\n" | |
354 | " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" | |
355 | "(array-ref freds-center 0 0) @result{} foo\n" | |
1e6808ea | 356 | "@end lisp") |
1bbd0b84 | 357 | #define FUNC_NAME s_scm_make_shared_array |
0f2d19dd | 358 | { |
112ba0ac | 359 | scm_t_array_handle old_handle; |
0f2d19dd JB |
360 | SCM ra; |
361 | SCM inds, indptr; | |
362 | SCM imap; | |
112ba0ac MV |
363 | size_t k; |
364 | ssize_t i; | |
2b829bbb | 365 | long old_base, old_min, new_min, old_max, new_max; |
92c2555f | 366 | scm_t_array_dim *s; |
b3fcac34 DH |
367 | |
368 | SCM_VALIDATE_REST_ARGUMENT (dims); | |
34d19ef6 | 369 | SCM_VALIDATE_PROC (2, mapfunc); |
0cd6cb2f | 370 | ra = scm_i_shap2ra (dims); |
112ba0ac MV |
371 | |
372 | scm_array_get_handle (oldra, &old_handle); | |
373 | ||
04b87de5 | 374 | if (SCM_I_ARRAYP (oldra)) |
0f2d19dd | 375 | { |
65704b98 | 376 | SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra)); |
2b829bbb | 377 | old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); |
112ba0ac MV |
378 | s = scm_array_handle_dims (&old_handle); |
379 | k = scm_array_handle_rank (&old_handle); | |
0f2d19dd JB |
380 | while (k--) |
381 | { | |
382 | if (s[k].inc > 0) | |
383 | old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
384 | else | |
385 | old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
386 | } | |
387 | } | |
388 | else | |
389 | { | |
65704b98 | 390 | SCM_I_ARRAY_SET_V (ra, oldra); |
2b829bbb | 391 | old_base = old_min = 0; |
9da9c22f | 392 | old_max = scm_c_array_length (oldra) - 1; |
0f2d19dd | 393 | } |
112ba0ac | 394 | |
0f2d19dd | 395 | inds = SCM_EOL; |
04b87de5 MV |
396 | s = SCM_I_ARRAY_DIMS (ra); |
397 | for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) | |
0f2d19dd | 398 | { |
1e2a55e4 | 399 | inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds); |
0f2d19dd JB |
400 | if (s[k].ubnd < s[k].lbnd) |
401 | { | |
04b87de5 | 402 | if (1 == SCM_I_ARRAY_NDIM (ra)) |
943a0a87 AW |
403 | ra = scm_make_generalized_vector (scm_array_type (ra), |
404 | SCM_INUM0, SCM_UNDEFINED); | |
0f2d19dd | 405 | else |
65704b98 DL |
406 | SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra), |
407 | SCM_INUM0, SCM_UNDEFINED)); | |
112ba0ac | 408 | scm_array_handle_release (&old_handle); |
0f2d19dd JB |
409 | return ra; |
410 | } | |
411 | } | |
112ba0ac | 412 | |
fdc28395 | 413 | imap = scm_apply_0 (mapfunc, scm_reverse (inds)); |
0cd6cb2f | 414 | i = scm_array_handle_pos (&old_handle, imap); |
65704b98 DL |
415 | new_min = new_max = i + old_base; |
416 | SCM_I_ARRAY_SET_BASE (ra, new_min); | |
0f2d19dd | 417 | indptr = inds; |
04b87de5 | 418 | k = SCM_I_ARRAY_NDIM (ra); |
0f2d19dd JB |
419 | while (k--) |
420 | { | |
421 | if (s[k].ubnd > s[k].lbnd) | |
422 | { | |
e11e83f3 | 423 | SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); |
fdc28395 | 424 | imap = scm_apply_0 (mapfunc, scm_reverse (inds)); |
0cd6cb2f | 425 | s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; |
0f2d19dd JB |
426 | i += s[k].inc; |
427 | if (s[k].inc > 0) | |
428 | new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
429 | else | |
430 | new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
431 | } | |
432 | else | |
433 | s[k].inc = new_max - new_min + 1; /* contiguous by default */ | |
434 | indptr = SCM_CDR (indptr); | |
435 | } | |
112ba0ac MV |
436 | |
437 | scm_array_handle_release (&old_handle); | |
438 | ||
b3fcac34 DH |
439 | if (old_min > new_min || old_max < new_max) |
440 | SCM_MISC_ERROR ("mapping out of range", SCM_EOL); | |
04b87de5 | 441 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) |
0f2d19dd | 442 | { |
04b87de5 | 443 | SCM v = SCM_I_ARRAY_V (ra); |
9da9c22f | 444 | size_t length = scm_c_array_length (v); |
74014c46 DH |
445 | if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) |
446 | return v; | |
0f2d19dd | 447 | if (s->ubnd < s->lbnd) |
943a0a87 AW |
448 | return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, |
449 | SCM_UNDEFINED); | |
0f2d19dd | 450 | } |
0cd6cb2f | 451 | scm_i_ra_set_contp (ra); |
0f2d19dd JB |
452 | return ra; |
453 | } | |
1bbd0b84 | 454 | #undef FUNC_NAME |
0f2d19dd JB |
455 | |
456 | ||
457 | /* args are RA . DIMS */ | |
65704b98 | 458 | SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, |
af45e3b0 | 459 | (SCM ra, SCM args), |
b7e64f8b | 460 | "Return an array sharing contents with @var{ra}, but with\n" |
1e6808ea | 461 | "dimensions arranged in a different order. There must be one\n" |
b7e64f8b | 462 | "@var{dim} argument for each dimension of @var{ra}.\n" |
1e6808ea MG |
463 | "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" |
464 | "and the rank of the array to be returned. Each integer in that\n" | |
465 | "range must appear at least once in the argument list.\n" | |
466 | "\n" | |
467 | "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" | |
468 | "dimensions in the array to be returned, their positions in the\n" | |
b7e64f8b | 469 | "argument list to dimensions of @var{ra}. Several @var{dim}s\n" |
1e6808ea | 470 | "may have the same value, in which case the returned array will\n" |
b7e64f8b | 471 | "have smaller rank than @var{ra}.\n" |
1e6808ea MG |
472 | "\n" |
473 | "@lisp\n" | |
b380b885 MD |
474 | "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" |
475 | "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" | |
476 | "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" | |
477 | " #2((a 4) (b 5) (c 6))\n" | |
1e6808ea | 478 | "@end lisp") |
1bbd0b84 | 479 | #define FUNC_NAME s_scm_transpose_array |
0f2d19dd | 480 | { |
34d19ef6 | 481 | SCM res, vargs; |
92c2555f | 482 | scm_t_array_dim *s, *r; |
0f2d19dd | 483 | int ndim, i, k; |
af45e3b0 | 484 | |
b3fcac34 | 485 | SCM_VALIDATE_REST_ARGUMENT (args); |
8c5bb729 | 486 | SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME); |
e0e49670 | 487 | |
a6f8d3dd | 488 | switch (scm_c_array_rank (ra)) |
e0e49670 | 489 | { |
a6f8d3dd DL |
490 | case 0: |
491 | if (!scm_is_null (args)) | |
492 | SCM_WRONG_NUM_ARGS (); | |
493 | return ra; | |
494 | case 1: | |
e0e49670 | 495 | /* Make sure that we are called with a single zero as |
a6f8d3dd | 496 | arguments. |
e0e49670 MV |
497 | */ |
498 | if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) | |
499 | SCM_WRONG_NUM_ARGS (); | |
500 | SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); | |
501 | SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); | |
502 | return ra; | |
a6f8d3dd | 503 | default: |
0f2d19dd | 504 | vargs = scm_vector (args); |
04b87de5 | 505 | if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) |
b3fcac34 | 506 | SCM_WRONG_NUM_ARGS (); |
0f2d19dd | 507 | ndim = 0; |
04b87de5 | 508 | for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) |
0f2d19dd | 509 | { |
6e708ef2 | 510 | i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), |
04b87de5 | 511 | 0, SCM_I_ARRAY_NDIM(ra)); |
0f2d19dd JB |
512 | if (ndim < i) |
513 | ndim = i; | |
514 | } | |
515 | ndim++; | |
66b9d7d3 | 516 | res = scm_i_make_array (ndim); |
65704b98 DL |
517 | SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra)); |
518 | SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra)); | |
0f2d19dd JB |
519 | for (k = ndim; k--;) |
520 | { | |
04b87de5 MV |
521 | SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; |
522 | SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; | |
0f2d19dd | 523 | } |
04b87de5 | 524 | for (k = SCM_I_ARRAY_NDIM (ra); k--;) |
0f2d19dd | 525 | { |
6e708ef2 | 526 | i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); |
04b87de5 MV |
527 | s = &(SCM_I_ARRAY_DIMS (ra)[k]); |
528 | r = &(SCM_I_ARRAY_DIMS (res)[i]); | |
0f2d19dd JB |
529 | if (r->ubnd < r->lbnd) |
530 | { | |
531 | r->lbnd = s->lbnd; | |
532 | r->ubnd = s->ubnd; | |
533 | r->inc = s->inc; | |
534 | ndim--; | |
535 | } | |
536 | else | |
537 | { | |
538 | if (r->ubnd > s->ubnd) | |
539 | r->ubnd = s->ubnd; | |
540 | if (r->lbnd < s->lbnd) | |
541 | { | |
65704b98 | 542 | SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc); |
0f2d19dd JB |
543 | r->lbnd = s->lbnd; |
544 | } | |
545 | r->inc += s->inc; | |
546 | } | |
547 | } | |
b3fcac34 DH |
548 | if (ndim > 0) |
549 | SCM_MISC_ERROR ("bad argument list", SCM_EOL); | |
0cd6cb2f | 550 | scm_i_ra_set_contp (res); |
0f2d19dd JB |
551 | return res; |
552 | } | |
553 | } | |
1bbd0b84 | 554 | #undef FUNC_NAME |
0f2d19dd | 555 | |
1d7bdb25 GH |
556 | /* attempts to unroll an array into a one-dimensional array. |
557 | returns the unrolled array or #f if it can't be done. */ | |
35f45ed6 DL |
558 | /* if strict is true, return #f if returned array |
559 | wouldn't have contiguous elements. */ | |
3b3b36dd | 560 | SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, |
1bbd0b84 | 561 | (SCM ra, SCM strict), |
b7e64f8b BT |
562 | "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n" |
563 | "array without changing their order (last subscript changing\n" | |
564 | "fastest), then @code{array-contents} returns that shared array,\n" | |
565 | "otherwise it returns @code{#f}. All arrays made by\n" | |
566 | "@code{make-array} and @code{make-uniform-array} may be unrolled,\n" | |
567 | "some arrays made by @code{make-shared-array} may not be. If\n" | |
568 | "the optional argument @var{strict} is provided, a shared array\n" | |
569 | "will be returned only if its elements are stored internally\n" | |
570 | "contiguous in memory.") | |
1bbd0b84 | 571 | #define FUNC_NAME s_scm_array_contents |
0f2d19dd | 572 | { |
c545f716 DL |
573 | if (!scm_is_array (ra)) |
574 | scm_wrong_type_arg_msg (NULL, 0, ra, "array"); | |
575 | else if (SCM_I_ARRAYP (ra)) | |
0f2d19dd | 576 | { |
c545f716 | 577 | SCM v; |
04b87de5 | 578 | size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; |
c545f716 | 579 | if (!SCM_I_ARRAY_CONTP (ra)) |
20930f28 MV |
580 | return SCM_BOOL_F; |
581 | for (k = 0; k < ndim; k++) | |
04b87de5 | 582 | len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; |
943a0a87 | 583 | if (!SCM_UNBNDP (strict) && scm_is_true (strict)) |
74014c46 | 584 | { |
04b87de5 | 585 | if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) |
20930f28 | 586 | return SCM_BOOL_F; |
04b87de5 | 587 | if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) |
20930f28 | 588 | { |
04b87de5 MV |
589 | if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || |
590 | SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || | |
20930f28 MV |
591 | len % SCM_LONG_BIT) |
592 | return SCM_BOOL_F; | |
593 | } | |
74014c46 | 594 | } |
9da9c22f | 595 | |
c545f716 | 596 | v = SCM_I_ARRAY_V (ra); |
2c1ccb02 DL |
597 | if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))) |
598 | return v; | |
c545f716 DL |
599 | else |
600 | { | |
601 | SCM sra = scm_i_make_array (1); | |
602 | SCM_I_ARRAY_DIMS (sra)->lbnd = 0; | |
603 | SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; | |
65704b98 DL |
604 | SCM_I_ARRAY_SET_V (sra, v); |
605 | SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra)); | |
c545f716 DL |
606 | SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); |
607 | return sra; | |
608 | } | |
0f2d19dd | 609 | } |
02339e5b | 610 | else |
c545f716 | 611 | return ra; |
0f2d19dd | 612 | } |
1bbd0b84 | 613 | #undef FUNC_NAME |
0f2d19dd | 614 | |
1cc91f1b | 615 | |
943a0a87 AW |
616 | static void |
617 | list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) | |
618 | { | |
619 | if (k == scm_array_handle_rank (handle)) | |
620 | scm_array_handle_set (handle, pos, lst); | |
621 | else | |
622 | { | |
623 | scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; | |
624 | ssize_t inc = dim->inc; | |
625 | size_t len = 1 + dim->ubnd - dim->lbnd, n; | |
626 | char *errmsg = NULL; | |
627 | ||
628 | n = len; | |
629 | while (n > 0 && scm_is_pair (lst)) | |
630 | { | |
631 | list_to_array (SCM_CAR (lst), handle, pos, k + 1); | |
632 | pos += inc; | |
633 | lst = SCM_CDR (lst); | |
634 | n -= 1; | |
635 | } | |
636 | if (n != 0) | |
637 | errmsg = "too few elements for array dimension ~a, need ~a"; | |
638 | if (!scm_is_null (lst)) | |
639 | errmsg = "too many elements for array dimension ~a, want ~a"; | |
640 | if (errmsg) | |
1e2a55e4 | 641 | scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k), |
943a0a87 AW |
642 | scm_from_size_t (len))); |
643 | } | |
644 | } | |
1e2a55e4 | 645 | |
1cc91f1b | 646 | |
f301dbf3 | 647 | SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, |
2caaadd1 | 648 | (SCM type, SCM shape, SCM lst), |
f301dbf3 MV |
649 | "Return an array of the type @var{type}\n" |
650 | "with elements the same as those of @var{lst}.\n" | |
bfad4005 | 651 | "\n" |
2caaadd1 MV |
652 | "The argument @var{shape} determines the number of dimensions\n" |
653 | "of the array and their shape. It is either an exact integer,\n" | |
654 | "giving the\n" | |
655 | "number of dimensions directly, or a list whose length\n" | |
656 | "specifies the number of dimensions and each element specified\n" | |
657 | "the lower and optionally the upper bound of the corresponding\n" | |
658 | "dimension.\n" | |
659 | "When the element is list of two elements, these elements\n" | |
660 | "give the lower and upper bounds. When it is an exact\n" | |
661 | "integer, it gives only the lower bound.") | |
f301dbf3 | 662 | #define FUNC_NAME s_scm_list_to_typed_array |
0f2d19dd | 663 | { |
2caaadd1 | 664 | SCM row; |
0f2d19dd | 665 | SCM ra; |
bcbbea0e | 666 | scm_t_array_handle handle; |
bfad4005 | 667 | |
bfad4005 | 668 | row = lst; |
2caaadd1 | 669 | if (scm_is_integer (shape)) |
0f2d19dd | 670 | { |
2caaadd1 MV |
671 | size_t k = scm_to_size_t (shape); |
672 | shape = SCM_EOL; | |
bfad4005 MV |
673 | while (k-- > 0) |
674 | { | |
675 | shape = scm_cons (scm_length (row), shape); | |
2caaadd1 | 676 | if (k > 0 && !scm_is_null (row)) |
bfad4005 MV |
677 | row = scm_car (row); |
678 | } | |
679 | } | |
680 | else | |
681 | { | |
2caaadd1 MV |
682 | SCM shape_spec = shape; |
683 | shape = SCM_EOL; | |
bfad4005 MV |
684 | while (1) |
685 | { | |
2caaadd1 MV |
686 | SCM spec = scm_car (shape_spec); |
687 | if (scm_is_pair (spec)) | |
688 | shape = scm_cons (spec, shape); | |
689 | else | |
690 | shape = scm_cons (scm_list_2 (spec, | |
691 | scm_sum (scm_sum (spec, | |
692 | scm_length (row)), | |
693 | scm_from_int (-1))), | |
694 | shape); | |
695 | shape_spec = scm_cdr (shape_spec); | |
696 | if (scm_is_pair (shape_spec)) | |
697 | { | |
698 | if (!scm_is_null (row)) | |
699 | row = scm_car (row); | |
700 | } | |
bfad4005 MV |
701 | else |
702 | break; | |
703 | } | |
0f2d19dd | 704 | } |
bfad4005 | 705 | |
f0b91039 MV |
706 | ra = scm_make_typed_array (type, SCM_UNSPECIFIED, |
707 | scm_reverse_x (shape, SCM_EOL)); | |
20930f28 | 708 | |
bcbbea0e | 709 | scm_array_get_handle (ra, &handle); |
943a0a87 | 710 | list_to_array (lst, &handle, 0, 0); |
bcbbea0e MV |
711 | scm_array_handle_release (&handle); |
712 | ||
713 | return ra; | |
0f2d19dd | 714 | } |
1bbd0b84 | 715 | #undef FUNC_NAME |
0f2d19dd | 716 | |
f301dbf3 MV |
717 | SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, |
718 | (SCM ndim, SCM lst), | |
719 | "Return an array with elements the same as those of @var{lst}.") | |
720 | #define FUNC_NAME s_scm_list_to_array | |
721 | { | |
722 | return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); | |
723 | } | |
724 | #undef FUNC_NAME | |
725 | ||
e0e49670 MV |
726 | /* Print dimension DIM of ARRAY. |
727 | */ | |
0f2d19dd | 728 | |
e0e49670 | 729 | static int |
943a0a87 | 730 | scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, |
e0e49670 MV |
731 | SCM port, scm_print_state *pstate) |
732 | { | |
943a0a87 AW |
733 | if (dim == h->ndims) |
734 | scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate); | |
735 | else | |
e0e49670 | 736 | { |
943a0a87 | 737 | ssize_t i; |
0607ebbf | 738 | scm_putc_unlocked ('(', port); |
943a0a87 AW |
739 | for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd; |
740 | i++, pos += h->dims[dim].inc) | |
741 | { | |
742 | scm_i_print_array_dimension (h, dim+1, pos, port, pstate); | |
743 | if (i < h->dims[dim].ubnd) | |
0607ebbf | 744 | scm_putc_unlocked (' ', port); |
943a0a87 | 745 | } |
0607ebbf | 746 | scm_putc_unlocked (')', port); |
e0e49670 | 747 | } |
e0e49670 MV |
748 | return 1; |
749 | } | |
750 | ||
943a0a87 | 751 | /* Print an array. |
e0e49670 MV |
752 | */ |
753 | ||
b2637c98 | 754 | int |
e0e49670 MV |
755 | scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) |
756 | { | |
943a0a87 | 757 | scm_t_array_handle h; |
1e2a55e4 | 758 | size_t i; |
2caaadd1 | 759 | int print_lbnds = 0, zero_size = 0, print_lens = 0; |
e0e49670 | 760 | |
943a0a87 AW |
761 | scm_array_get_handle (array, &h); |
762 | ||
0607ebbf | 763 | scm_putc_unlocked ('#', port); |
eb3d623d | 764 | if (SCM_I_ARRAYP (array)) |
943a0a87 AW |
765 | scm_intprint (h.ndims, 10, port); |
766 | if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) | |
767 | scm_write (scm_array_handle_element_type (&h), port); | |
65704b98 | 768 | |
943a0a87 | 769 | for (i = 0; i < h.ndims; i++) |
2caaadd1 | 770 | { |
943a0a87 | 771 | if (h.dims[i].lbnd != 0) |
2caaadd1 | 772 | print_lbnds = 1; |
943a0a87 | 773 | if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0) |
2caaadd1 MV |
774 | zero_size = 1; |
775 | else if (zero_size) | |
776 | print_lens = 1; | |
777 | } | |
778 | ||
779 | if (print_lbnds || print_lens) | |
943a0a87 | 780 | for (i = 0; i < h.ndims; i++) |
e0e49670 | 781 | { |
2caaadd1 | 782 | if (print_lbnds) |
e0e49670 | 783 | { |
0607ebbf | 784 | scm_putc_unlocked ('@', port); |
943a0a87 | 785 | scm_intprint (h.dims[i].lbnd, 10, port); |
2caaadd1 MV |
786 | } |
787 | if (print_lens) | |
788 | { | |
0607ebbf | 789 | scm_putc_unlocked (':', port); |
943a0a87 | 790 | scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, |
2caaadd1 | 791 | 10, port); |
e0e49670 | 792 | } |
e0e49670 MV |
793 | } |
794 | ||
943a0a87 | 795 | if (h.ndims == 0) |
5f37cb63 MV |
796 | { |
797 | /* Rank zero arrays, which are really just scalars, are printed | |
798 | specially. The consequent way would be to print them as | |
799 | ||
800 | #0 OBJ | |
801 | ||
802 | where OBJ is the printed representation of the scalar, but we | |
803 | print them instead as | |
804 | ||
805 | #0(OBJ) | |
806 | ||
807 | to make them look less strange. | |
808 | ||
809 | Just printing them as | |
810 | ||
811 | OBJ | |
812 | ||
813 | would be correct in a way as well, but zero rank arrays are | |
814 | not really the same as Scheme values since they are boxed and | |
815 | can be modified with array-set!, say. | |
816 | */ | |
0607ebbf | 817 | scm_putc_unlocked ('(', port); |
943a0a87 | 818 | scm_i_print_array_dimension (&h, 0, 0, port, pstate); |
0607ebbf | 819 | scm_putc_unlocked (')', port); |
5f37cb63 MV |
820 | return 1; |
821 | } | |
822 | else | |
943a0a87 | 823 | return scm_i_print_array_dimension (&h, 0, 0, port, pstate); |
e0e49670 | 824 | } |
1cc91f1b | 825 | |
0f2d19dd | 826 | void |
2fa901a5 | 827 | scm_init_arrays () |
0f2d19dd | 828 | { |
0f2d19dd | 829 | scm_add_feature ("array"); |
20930f28 | 830 | |
2fa901a5 | 831 | #include "libguile/arrays.x" |
bfad4005 | 832 | |
0f2d19dd | 833 | } |
89e00824 ML |
834 | |
835 | /* | |
836 | Local Variables: | |
837 | c-file-style: "gnu" | |
838 | End: | |
839 | */ |