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