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