Commit | Line | Data |
---|---|---|
438974d0 | 1 | /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 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" | |
36 | #include "libguile/smob.h" | |
a0599745 MD |
37 | #include "libguile/feature.h" |
38 | #include "libguile/root.h" | |
39 | #include "libguile/strings.h" | |
c44ca4fe | 40 | #include "libguile/srfi-13.h" |
e0e49670 | 41 | #include "libguile/srfi-4.h" |
a0599745 | 42 | #include "libguile/vectors.h" |
cf396142 | 43 | #include "libguile/bitvectors.h" |
438974d0 | 44 | #include "libguile/bytevectors.h" |
bfad4005 | 45 | #include "libguile/list.h" |
d44ff083 | 46 | #include "libguile/dynwind.h" |
a0599745 MD |
47 | |
48 | #include "libguile/validate.h" | |
2fa901a5 | 49 | #include "libguile/arrays.h" |
1030b450 | 50 | #include "libguile/generalized-arrays.h" |
f332e957 | 51 | #include "libguile/generalized-vectors.h" |
476b894c | 52 | #include "libguile/uniform.h" |
5d1b3b2d | 53 | #include "libguile/array-map.h" |
f27d2057 | 54 | #include "libguile/print.h" |
bfad4005 | 55 | #include "libguile/read.h" |
0f2d19dd | 56 | |
3d8d56df GH |
57 | #ifdef HAVE_UNISTD_H |
58 | #include <unistd.h> | |
59 | #endif | |
60 | ||
7beabedb MG |
61 | #ifdef HAVE_IO_H |
62 | #include <io.h> | |
63 | #endif | |
64 | ||
0f2d19dd JB |
65 | \f |
66 | /* The set of uniform scm_vector types is: | |
e0e49670 | 67 | * Vector of: Called: Replaced by: |
bfad4005 | 68 | * unsigned char string |
85368844 | 69 | * char byvect s8 or u8, depending on signedness of 'char' |
e0e49670 MV |
70 | * boolean bvect |
71 | * signed long ivect s32 | |
72 | * unsigned long uvect u32 | |
73 | * float fvect f32 | |
74 | * double dvect d32 | |
85368844 | 75 | * complex double cvect c64 |
e0e49670 MV |
76 | * short svect s16 |
77 | * long long llvect s64 | |
0f2d19dd JB |
78 | */ |
79 | ||
04b87de5 | 80 | scm_t_bits scm_i_tc16_array; |
04b87de5 MV |
81 | |
82 | #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ | |
83 | (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) | |
84 | #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ | |
85 | (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) | |
1cc91f1b | 86 | |
f301dbf3 MV |
87 | typedef SCM creator_proc (SCM len, SCM fill); |
88 | ||
89 | struct { | |
90 | char *type_name; | |
91 | SCM type; | |
92 | creator_proc *creator; | |
93 | } type_creator_table[] = { | |
94 | { "a", SCM_UNSPECIFIED, scm_make_string }, | |
95 | { "b", SCM_UNSPECIFIED, scm_make_bitvector }, | |
96 | { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, | |
97 | { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, | |
98 | { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, | |
99 | { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, | |
100 | { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, | |
101 | { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, | |
102 | { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, | |
103 | { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, | |
104 | { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, | |
105 | { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, | |
106 | { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, | |
107 | { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, | |
438974d0 | 108 | { "vu8", SCM_UNSPECIFIED, scm_make_bytevector }, |
f301dbf3 MV |
109 | { NULL } |
110 | }; | |
111 | ||
112 | static void | |
113 | init_type_creator_table () | |
114 | { | |
115 | int i; | |
116 | for (i = 0; type_creator_table[i].type_name; i++) | |
117 | { | |
118 | SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); | |
119 | type_creator_table[i].type = scm_permanent_object (sym); | |
120 | } | |
121 | } | |
122 | ||
123 | static creator_proc * | |
124 | type_to_creator (SCM type) | |
125 | { | |
126 | int i; | |
127 | ||
128 | if (scm_is_eq (type, SCM_BOOL_T)) | |
129 | return scm_make_vector; | |
130 | for (i = 0; type_creator_table[i].type_name; i++) | |
131 | if (scm_is_eq (type, type_creator_table[i].type)) | |
132 | return type_creator_table[i].creator; | |
133 | ||
134 | scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); | |
135 | } | |
136 | ||
137 | static SCM | |
138 | make_typed_vector (SCM type, size_t len) | |
139 | { | |
140 | creator_proc *creator = type_to_creator (type); | |
141 | return creator (scm_from_size_t (len), SCM_UNDEFINED); | |
142 | } | |
bfad4005 | 143 | |
0f2d19dd | 144 | |
e2d37336 MD |
145 | SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, |
146 | (SCM ra), | |
147 | "Return the root vector of a shared array.") | |
148 | #define FUNC_NAME s_scm_shared_array_root | |
149 | { | |
66b9d7d3 | 150 | if (SCM_I_ARRAYP (ra)) |
04b87de5 | 151 | return SCM_I_ARRAY_V (ra); |
52372719 MV |
152 | else if (scm_is_generalized_vector (ra)) |
153 | return ra; | |
154 | scm_wrong_type_arg_msg (NULL, 0, ra, "array"); | |
e2d37336 MD |
155 | } |
156 | #undef FUNC_NAME | |
157 | ||
158 | ||
159 | SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, | |
160 | (SCM ra), | |
161 | "Return the root vector index of the first element in the array.") | |
162 | #define FUNC_NAME s_scm_shared_array_offset | |
163 | { | |
52372719 MV |
164 | scm_t_array_handle handle; |
165 | SCM res; | |
166 | ||
167 | scm_array_get_handle (ra, &handle); | |
168 | res = scm_from_size_t (handle.base); | |
169 | scm_array_handle_release (&handle); | |
170 | return res; | |
e2d37336 MD |
171 | } |
172 | #undef FUNC_NAME | |
173 | ||
174 | ||
175 | SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, | |
176 | (SCM ra), | |
177 | "For each dimension, return the distance between elements in the root vector.") | |
178 | #define FUNC_NAME s_scm_shared_array_increments | |
179 | { | |
52372719 | 180 | scm_t_array_handle handle; |
e2d37336 | 181 | SCM res = SCM_EOL; |
1be6b49c | 182 | size_t k; |
92c2555f | 183 | scm_t_array_dim *s; |
02339e5b | 184 | |
52372719 MV |
185 | scm_array_get_handle (ra, &handle); |
186 | k = scm_array_handle_rank (&handle); | |
187 | s = scm_array_handle_dims (&handle); | |
e2d37336 | 188 | while (k--) |
52372719 MV |
189 | res = scm_cons (scm_from_ssize_t (s[k].inc), res); |
190 | scm_array_handle_release (&handle); | |
e2d37336 MD |
191 | return res; |
192 | } | |
193 | #undef FUNC_NAME | |
194 | ||
0cd6cb2f | 195 | SCM |
66b9d7d3 | 196 | scm_i_make_array (int ndim) |
0f2d19dd JB |
197 | { |
198 | SCM ra; | |
66b9d7d3 | 199 | SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array, |
04b87de5 | 200 | scm_gc_malloc ((sizeof (scm_i_t_array) + |
4c9419ac MV |
201 | ndim * sizeof (scm_t_array_dim)), |
202 | "array")); | |
04b87de5 | 203 | SCM_I_ARRAY_V (ra) = SCM_BOOL_F; |
0f2d19dd JB |
204 | return ra; |
205 | } | |
206 | ||
207 | static char s_bad_spec[] = "Bad scm_array dimension"; | |
0f2d19dd | 208 | |
1cc91f1b | 209 | |
02339e5b MV |
210 | /* Increments will still need to be set. */ |
211 | ||
0cd6cb2f MV |
212 | static SCM |
213 | scm_i_shap2ra (SCM args) | |
0f2d19dd | 214 | { |
92c2555f | 215 | scm_t_array_dim *s; |
0f2d19dd JB |
216 | SCM ra, spec, sp; |
217 | int ndim = scm_ilength (args); | |
b3fcac34 | 218 | if (ndim < 0) |
0cd6cb2f | 219 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
b3fcac34 | 220 | |
66b9d7d3 | 221 | ra = scm_i_make_array (ndim); |
04b87de5 MV |
222 | SCM_I_ARRAY_BASE (ra) = 0; |
223 | s = SCM_I_ARRAY_DIMS (ra); | |
d2e53ed6 | 224 | for (; !scm_is_null (args); s++, args = SCM_CDR (args)) |
0f2d19dd JB |
225 | { |
226 | spec = SCM_CAR (args); | |
e11e83f3 | 227 | if (scm_is_integer (spec)) |
0f2d19dd | 228 | { |
e11e83f3 | 229 | if (scm_to_long (spec) < 0) |
0cd6cb2f | 230 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
0f2d19dd | 231 | s->lbnd = 0; |
e11e83f3 | 232 | s->ubnd = scm_to_long (spec) - 1; |
0f2d19dd JB |
233 | s->inc = 1; |
234 | } | |
235 | else | |
236 | { | |
d2e53ed6 | 237 | if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) |
0cd6cb2f | 238 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
e11e83f3 | 239 | s->lbnd = scm_to_long (SCM_CAR (spec)); |
0f2d19dd | 240 | sp = SCM_CDR (spec); |
d2e53ed6 | 241 | if (!scm_is_pair (sp) |
e11e83f3 | 242 | || !scm_is_integer (SCM_CAR (sp)) |
d2e53ed6 | 243 | || !scm_is_null (SCM_CDR (sp))) |
0cd6cb2f | 244 | scm_misc_error (NULL, s_bad_spec, SCM_EOL); |
e11e83f3 | 245 | s->ubnd = scm_to_long (SCM_CAR (sp)); |
0f2d19dd JB |
246 | s->inc = 1; |
247 | } | |
248 | } | |
249 | return ra; | |
250 | } | |
251 | ||
f301dbf3 MV |
252 | SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, |
253 | (SCM type, SCM fill, SCM bounds), | |
254 | "Create and return an array of type @var{type}.") | |
255 | #define FUNC_NAME s_scm_make_typed_array | |
0f2d19dd | 256 | { |
f301dbf3 | 257 | size_t k, rlen = 1; |
92c2555f | 258 | scm_t_array_dim *s; |
f301dbf3 | 259 | creator_proc *creator; |
0f2d19dd | 260 | SCM ra; |
1be6b49c | 261 | |
f301dbf3 | 262 | creator = type_to_creator (type); |
0cd6cb2f | 263 | ra = scm_i_shap2ra (bounds); |
e038c042 | 264 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); |
04b87de5 MV |
265 | s = SCM_I_ARRAY_DIMS (ra); |
266 | k = SCM_I_ARRAY_NDIM (ra); | |
1be6b49c | 267 | |
0f2d19dd JB |
268 | while (k--) |
269 | { | |
a3a32939 | 270 | s[k].inc = rlen; |
2caaadd1 | 271 | SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); |
0f2d19dd | 272 | rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; |
0f2d19dd | 273 | } |
a3a32939 | 274 | |
f0b91039 | 275 | if (scm_is_eq (fill, SCM_UNSPECIFIED)) |
f301dbf3 | 276 | fill = SCM_UNDEFINED; |
a3a32939 | 277 | |
04b87de5 | 278 | SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill); |
a3a32939 | 279 | |
04b87de5 | 280 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) |
c014a02e | 281 | if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) |
04b87de5 | 282 | return SCM_I_ARRAY_V (ra); |
0f2d19dd JB |
283 | return ra; |
284 | } | |
1bbd0b84 | 285 | #undef FUNC_NAME |
0f2d19dd | 286 | |
782a82ee AW |
287 | SCM |
288 | scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, | |
289 | size_t byte_len) | |
290 | #define FUNC_NAME "scm_from_contiguous_typed_array" | |
291 | { | |
292 | size_t k, rlen = 1; | |
293 | scm_t_array_dim *s; | |
294 | creator_proc *creator; | |
295 | SCM ra; | |
296 | scm_t_array_handle h; | |
297 | void *base; | |
298 | size_t sz; | |
299 | ||
300 | creator = type_to_creator (type); | |
301 | ra = scm_i_shap2ra (bounds); | |
302 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); | |
303 | s = SCM_I_ARRAY_DIMS (ra); | |
304 | k = SCM_I_ARRAY_NDIM (ra); | |
305 | ||
306 | while (k--) | |
307 | { | |
308 | s[k].inc = rlen; | |
309 | SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); | |
310 | rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; | |
311 | } | |
312 | SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED); | |
313 | ||
314 | ||
315 | scm_array_get_handle (ra, &h); | |
316 | base = scm_array_handle_uniform_writable_elements (&h); | |
317 | sz = scm_array_handle_uniform_element_size (&h); | |
318 | scm_array_handle_release (&h); | |
319 | ||
320 | if (byte_len % sz) | |
321 | SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL); | |
322 | if (byte_len / sz != rlen) | |
323 | SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL); | |
324 | ||
325 | memcpy (base, bytes, byte_len); | |
326 | ||
327 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) | |
328 | if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) | |
329 | return SCM_I_ARRAY_V (ra); | |
330 | return ra; | |
331 | } | |
332 | #undef FUNC_NAME | |
333 | ||
f301dbf3 MV |
334 | SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, |
335 | (SCM fill, SCM bounds), | |
336 | "Create and return an array.") | |
337 | #define FUNC_NAME s_scm_make_array | |
338 | { | |
339 | return scm_make_typed_array (SCM_BOOL_T, fill, bounds); | |
340 | } | |
341 | #undef FUNC_NAME | |
342 | ||
0cd6cb2f MV |
343 | static void |
344 | scm_i_ra_set_contp (SCM ra) | |
0f2d19dd | 345 | { |
04b87de5 | 346 | size_t k = SCM_I_ARRAY_NDIM (ra); |
0f2d19dd | 347 | if (k) |
0f2d19dd | 348 | { |
04b87de5 | 349 | long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; |
fe0c6dae | 350 | while (k--) |
0f2d19dd | 351 | { |
04b87de5 | 352 | if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) |
fe0c6dae | 353 | { |
e038c042 | 354 | SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); |
fe0c6dae JB |
355 | return; |
356 | } | |
04b87de5 MV |
357 | inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd |
358 | - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); | |
0f2d19dd | 359 | } |
0f2d19dd | 360 | } |
e038c042 | 361 | SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); |
0f2d19dd JB |
362 | } |
363 | ||
364 | ||
3b3b36dd | 365 | SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, |
1bbd0b84 | 366 | (SCM oldra, SCM mapfunc, SCM dims), |
b380b885 MD |
367 | "@code{make-shared-array} can be used to create shared subarrays of other\n" |
368 | "arrays. The @var{mapper} is a function that translates coordinates in\n" | |
369 | "the new array into coordinates in the old array. A @var{mapper} must be\n" | |
370 | "linear, and its range must stay within the bounds of the old array, but\n" | |
371 | "it can be otherwise arbitrary. A simple example:\n" | |
1e6808ea | 372 | "@lisp\n" |
b380b885 MD |
373 | "(define fred (make-array #f 8 8))\n" |
374 | "(define freds-diagonal\n" | |
375 | " (make-shared-array fred (lambda (i) (list i i)) 8))\n" | |
376 | "(array-set! freds-diagonal 'foo 3)\n" | |
377 | "(array-ref fred 3 3) @result{} foo\n" | |
378 | "(define freds-center\n" | |
379 | " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" | |
380 | "(array-ref freds-center 0 0) @result{} foo\n" | |
1e6808ea | 381 | "@end lisp") |
1bbd0b84 | 382 | #define FUNC_NAME s_scm_make_shared_array |
0f2d19dd | 383 | { |
112ba0ac | 384 | scm_t_array_handle old_handle; |
0f2d19dd JB |
385 | SCM ra; |
386 | SCM inds, indptr; | |
387 | SCM imap; | |
112ba0ac MV |
388 | size_t k; |
389 | ssize_t i; | |
2b829bbb | 390 | long old_base, old_min, new_min, old_max, new_max; |
92c2555f | 391 | scm_t_array_dim *s; |
b3fcac34 DH |
392 | |
393 | SCM_VALIDATE_REST_ARGUMENT (dims); | |
34d19ef6 | 394 | SCM_VALIDATE_PROC (2, mapfunc); |
0cd6cb2f | 395 | ra = scm_i_shap2ra (dims); |
112ba0ac MV |
396 | |
397 | scm_array_get_handle (oldra, &old_handle); | |
398 | ||
04b87de5 | 399 | if (SCM_I_ARRAYP (oldra)) |
0f2d19dd | 400 | { |
04b87de5 | 401 | SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra); |
2b829bbb | 402 | old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); |
112ba0ac MV |
403 | s = scm_array_handle_dims (&old_handle); |
404 | k = scm_array_handle_rank (&old_handle); | |
0f2d19dd JB |
405 | while (k--) |
406 | { | |
407 | if (s[k].inc > 0) | |
408 | old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
409 | else | |
410 | old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
411 | } | |
412 | } | |
413 | else | |
414 | { | |
04b87de5 | 415 | SCM_I_ARRAY_V (ra) = oldra; |
2b829bbb | 416 | old_base = old_min = 0; |
02339e5b | 417 | old_max = scm_c_generalized_vector_length (oldra) - 1; |
0f2d19dd | 418 | } |
112ba0ac | 419 | |
0f2d19dd | 420 | inds = SCM_EOL; |
04b87de5 MV |
421 | s = SCM_I_ARRAY_DIMS (ra); |
422 | for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) | |
0f2d19dd | 423 | { |
e11e83f3 | 424 | inds = scm_cons (scm_from_long (s[k].lbnd), inds); |
0f2d19dd JB |
425 | if (s[k].ubnd < s[k].lbnd) |
426 | { | |
04b87de5 | 427 | if (1 == SCM_I_ARRAY_NDIM (ra)) |
f301dbf3 | 428 | ra = make_typed_vector (scm_array_type (ra), 0); |
0f2d19dd | 429 | else |
04b87de5 | 430 | SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); |
112ba0ac | 431 | scm_array_handle_release (&old_handle); |
0f2d19dd JB |
432 | return ra; |
433 | } | |
434 | } | |
112ba0ac | 435 | |
fdc28395 | 436 | imap = scm_apply_0 (mapfunc, scm_reverse (inds)); |
0cd6cb2f | 437 | i = scm_array_handle_pos (&old_handle, imap); |
2b829bbb | 438 | SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base; |
0f2d19dd | 439 | indptr = inds; |
04b87de5 | 440 | k = SCM_I_ARRAY_NDIM (ra); |
0f2d19dd JB |
441 | while (k--) |
442 | { | |
443 | if (s[k].ubnd > s[k].lbnd) | |
444 | { | |
e11e83f3 | 445 | SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); |
fdc28395 | 446 | imap = scm_apply_0 (mapfunc, scm_reverse (inds)); |
0cd6cb2f | 447 | s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; |
0f2d19dd JB |
448 | i += s[k].inc; |
449 | if (s[k].inc > 0) | |
450 | new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
451 | else | |
452 | new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; | |
453 | } | |
454 | else | |
455 | s[k].inc = new_max - new_min + 1; /* contiguous by default */ | |
456 | indptr = SCM_CDR (indptr); | |
457 | } | |
112ba0ac MV |
458 | |
459 | scm_array_handle_release (&old_handle); | |
460 | ||
b3fcac34 DH |
461 | if (old_min > new_min || old_max < new_max) |
462 | SCM_MISC_ERROR ("mapping out of range", SCM_EOL); | |
04b87de5 | 463 | if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) |
0f2d19dd | 464 | { |
04b87de5 | 465 | SCM v = SCM_I_ARRAY_V (ra); |
6e708ef2 | 466 | size_t length = scm_c_generalized_vector_length (v); |
74014c46 DH |
467 | if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) |
468 | return v; | |
0f2d19dd | 469 | if (s->ubnd < s->lbnd) |
f301dbf3 | 470 | return make_typed_vector (scm_array_type (ra), 0); |
0f2d19dd | 471 | } |
0cd6cb2f | 472 | scm_i_ra_set_contp (ra); |
0f2d19dd JB |
473 | return ra; |
474 | } | |
1bbd0b84 | 475 | #undef FUNC_NAME |
0f2d19dd JB |
476 | |
477 | ||
478 | /* args are RA . DIMS */ | |
af45e3b0 DH |
479 | SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, |
480 | (SCM ra, SCM args), | |
1e6808ea MG |
481 | "Return an array sharing contents with @var{array}, but with\n" |
482 | "dimensions arranged in a different order. There must be one\n" | |
483 | "@var{dim} argument for each dimension of @var{array}.\n" | |
484 | "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" | |
485 | "and the rank of the array to be returned. Each integer in that\n" | |
486 | "range must appear at least once in the argument list.\n" | |
487 | "\n" | |
488 | "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" | |
489 | "dimensions in the array to be returned, their positions in the\n" | |
490 | "argument list to dimensions of @var{array}. Several @var{dim}s\n" | |
491 | "may have the same value, in which case the returned array will\n" | |
492 | "have smaller rank than @var{array}.\n" | |
493 | "\n" | |
494 | "@lisp\n" | |
b380b885 MD |
495 | "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" |
496 | "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" | |
497 | "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" | |
498 | " #2((a 4) (b 5) (c 6))\n" | |
1e6808ea | 499 | "@end lisp") |
1bbd0b84 | 500 | #define FUNC_NAME s_scm_transpose_array |
0f2d19dd | 501 | { |
34d19ef6 | 502 | SCM res, vargs; |
92c2555f | 503 | scm_t_array_dim *s, *r; |
0f2d19dd | 504 | int ndim, i, k; |
af45e3b0 | 505 | |
b3fcac34 | 506 | SCM_VALIDATE_REST_ARGUMENT (args); |
1bbd0b84 | 507 | SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); |
e0e49670 | 508 | |
20930f28 | 509 | if (scm_is_generalized_vector (ra)) |
e0e49670 MV |
510 | { |
511 | /* Make sure that we are called with a single zero as | |
512 | arguments. | |
513 | */ | |
514 | if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) | |
515 | SCM_WRONG_NUM_ARGS (); | |
516 | SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); | |
517 | SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); | |
518 | return ra; | |
519 | } | |
520 | ||
66b9d7d3 | 521 | if (SCM_I_ARRAYP (ra)) |
0f2d19dd | 522 | { |
0f2d19dd | 523 | vargs = scm_vector (args); |
04b87de5 | 524 | if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) |
b3fcac34 | 525 | SCM_WRONG_NUM_ARGS (); |
0f2d19dd | 526 | ndim = 0; |
04b87de5 | 527 | for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) |
0f2d19dd | 528 | { |
6e708ef2 | 529 | i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), |
04b87de5 | 530 | 0, SCM_I_ARRAY_NDIM(ra)); |
0f2d19dd JB |
531 | if (ndim < i) |
532 | ndim = i; | |
533 | } | |
534 | ndim++; | |
66b9d7d3 | 535 | res = scm_i_make_array (ndim); |
04b87de5 MV |
536 | SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra); |
537 | SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra); | |
0f2d19dd JB |
538 | for (k = ndim; k--;) |
539 | { | |
04b87de5 MV |
540 | SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; |
541 | SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; | |
0f2d19dd | 542 | } |
04b87de5 | 543 | for (k = SCM_I_ARRAY_NDIM (ra); k--;) |
0f2d19dd | 544 | { |
6e708ef2 | 545 | i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); |
04b87de5 MV |
546 | s = &(SCM_I_ARRAY_DIMS (ra)[k]); |
547 | r = &(SCM_I_ARRAY_DIMS (res)[i]); | |
0f2d19dd JB |
548 | if (r->ubnd < r->lbnd) |
549 | { | |
550 | r->lbnd = s->lbnd; | |
551 | r->ubnd = s->ubnd; | |
552 | r->inc = s->inc; | |
553 | ndim--; | |
554 | } | |
555 | else | |
556 | { | |
557 | if (r->ubnd > s->ubnd) | |
558 | r->ubnd = s->ubnd; | |
559 | if (r->lbnd < s->lbnd) | |
560 | { | |
04b87de5 | 561 | SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; |
0f2d19dd JB |
562 | r->lbnd = s->lbnd; |
563 | } | |
564 | r->inc += s->inc; | |
565 | } | |
566 | } | |
b3fcac34 DH |
567 | if (ndim > 0) |
568 | SCM_MISC_ERROR ("bad argument list", SCM_EOL); | |
0cd6cb2f | 569 | scm_i_ra_set_contp (res); |
0f2d19dd JB |
570 | return res; |
571 | } | |
20930f28 MV |
572 | |
573 | scm_wrong_type_arg_msg (NULL, 0, ra, "array"); | |
0f2d19dd | 574 | } |
1bbd0b84 | 575 | #undef FUNC_NAME |
0f2d19dd | 576 | |
1d7bdb25 GH |
577 | /* attempts to unroll an array into a one-dimensional array. |
578 | returns the unrolled array or #f if it can't be done. */ | |
1bbd0b84 | 579 | /* if strict is not SCM_UNDEFINED, return #f if returned array |
1d7bdb25 | 580 | wouldn't have contiguous elements. */ |
3b3b36dd | 581 | SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, |
1bbd0b84 | 582 | (SCM ra, SCM strict), |
b380b885 MD |
583 | "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n" |
584 | "without changing their order (last subscript changing fastest), then\n" | |
585 | "@code{array-contents} returns that shared array, otherwise it returns\n" | |
586 | "@code{#f}. All arrays made by @var{make-array} and\n" | |
587 | "@var{make-uniform-array} may be unrolled, some arrays made by\n" | |
588 | "@var{make-shared-array} may not be.\n\n" | |
589 | "If the optional argument @var{strict} is provided, a shared array will\n" | |
590 | "be returned only if its elements are stored internally contiguous in\n" | |
591 | "memory.") | |
1bbd0b84 | 592 | #define FUNC_NAME s_scm_array_contents |
0f2d19dd JB |
593 | { |
594 | SCM sra; | |
e0e49670 | 595 | |
20930f28 | 596 | if (scm_is_generalized_vector (ra)) |
e0e49670 MV |
597 | return ra; |
598 | ||
04b87de5 | 599 | if (SCM_I_ARRAYP (ra)) |
0f2d19dd | 600 | { |
04b87de5 MV |
601 | size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; |
602 | if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra)) | |
20930f28 MV |
603 | return SCM_BOOL_F; |
604 | for (k = 0; k < ndim; k++) | |
04b87de5 | 605 | len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; |
20930f28 | 606 | if (!SCM_UNBNDP (strict)) |
74014c46 | 607 | { |
04b87de5 | 608 | if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) |
20930f28 | 609 | return SCM_BOOL_F; |
04b87de5 | 610 | if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) |
20930f28 | 611 | { |
04b87de5 MV |
612 | if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || |
613 | SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || | |
20930f28 MV |
614 | len % SCM_LONG_BIT) |
615 | return SCM_BOOL_F; | |
616 | } | |
74014c46 | 617 | } |
20930f28 MV |
618 | |
619 | { | |
04b87de5 | 620 | SCM v = SCM_I_ARRAY_V (ra); |
20930f28 | 621 | size_t length = scm_c_generalized_vector_length (v); |
04b87de5 | 622 | if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc) |
20930f28 | 623 | return v; |
0f2d19dd | 624 | } |
20930f28 | 625 | |
66b9d7d3 | 626 | sra = scm_i_make_array (1); |
04b87de5 MV |
627 | SCM_I_ARRAY_DIMS (sra)->lbnd = 0; |
628 | SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; | |
629 | SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra); | |
630 | SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); | |
631 | SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); | |
20930f28 | 632 | return sra; |
0f2d19dd | 633 | } |
02339e5b MV |
634 | else |
635 | scm_wrong_type_arg_msg (NULL, 0, ra, "array"); | |
0f2d19dd | 636 | } |
1bbd0b84 | 637 | #undef FUNC_NAME |
0f2d19dd | 638 | |
1cc91f1b | 639 | |
0f2d19dd | 640 | SCM |
6e8d25a6 | 641 | scm_ra2contig (SCM ra, int copy) |
0f2d19dd JB |
642 | { |
643 | SCM ret; | |
c014a02e ML |
644 | long inc = 1; |
645 | size_t k, len = 1; | |
04b87de5 MV |
646 | for (k = SCM_I_ARRAY_NDIM (ra); k--;) |
647 | len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; | |
648 | k = SCM_I_ARRAY_NDIM (ra); | |
649 | if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) | |
0f2d19dd | 650 | { |
04b87de5 | 651 | if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) |
0f2d19dd | 652 | return ra; |
04b87de5 MV |
653 | if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && |
654 | 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && | |
c014a02e | 655 | 0 == len % SCM_LONG_BIT)) |
0f2d19dd JB |
656 | return ra; |
657 | } | |
66b9d7d3 | 658 | ret = scm_i_make_array (k); |
04b87de5 | 659 | SCM_I_ARRAY_BASE (ret) = 0; |
0f2d19dd JB |
660 | while (k--) |
661 | { | |
04b87de5 MV |
662 | SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; |
663 | SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; | |
664 | SCM_I_ARRAY_DIMS (ret)[k].inc = inc; | |
665 | inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; | |
0f2d19dd | 666 | } |
04b87de5 | 667 | SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc); |
0f2d19dd JB |
668 | if (copy) |
669 | scm_array_copy_x (ra, ret); | |
670 | return ret; | |
671 | } | |
672 | ||
673 | ||
674 | ||
3b3b36dd | 675 | SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, |
03a5397a | 676 | (SCM ura, SCM port_or_fd, SCM start, SCM end), |
8f85c0c6 NJ |
677 | "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" |
678 | "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" | |
b380b885 | 679 | "binary objects from @var{port-or-fdes}.\n" |
8f85c0c6 NJ |
680 | "If an end of file is encountered,\n" |
681 | "the objects up to that point are put into @var{ura}\n" | |
b380b885 MD |
682 | "(starting at the beginning) and the remainder of the array is\n" |
683 | "unchanged.\n\n" | |
684 | "The optional arguments @var{start} and @var{end} allow\n" | |
685 | "a specified region of a vector (or linearized array) to be read,\n" | |
686 | "leaving the remainder of the vector unchanged.\n\n" | |
687 | "@code{uniform-array-read!} returns the number of objects read.\n" | |
688 | "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" | |
689 | "returned by @code{(current-input-port)}.") | |
1bbd0b84 | 690 | #define FUNC_NAME s_scm_uniform_array_read_x |
0f2d19dd | 691 | { |
3d8d56df | 692 | if (SCM_UNBNDP (port_or_fd)) |
9de87eea | 693 | port_or_fd = scm_current_input_port (); |
35de7ebe | 694 | |
03a5397a | 695 | if (scm_is_uniform_vector (ura)) |
20930f28 | 696 | { |
03a5397a | 697 | return scm_uniform_vector_read_x (ura, port_or_fd, start, end); |
20930f28 | 698 | } |
04b87de5 | 699 | else if (SCM_I_ARRAYP (ura)) |
20930f28 | 700 | { |
03a5397a MV |
701 | size_t base, vlen, cstart, cend; |
702 | SCM cra, ans; | |
703 | ||
704 | cra = scm_ra2contig (ura, 0); | |
04b87de5 MV |
705 | base = SCM_I_ARRAY_BASE (cra); |
706 | vlen = SCM_I_ARRAY_DIMS (cra)->inc * | |
707 | (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); | |
35de7ebe | 708 | |
03a5397a MV |
709 | cstart = 0; |
710 | cend = vlen; | |
711 | if (!SCM_UNBNDP (start)) | |
1146b6cd | 712 | { |
03a5397a MV |
713 | cstart = scm_to_unsigned_integer (start, 0, vlen); |
714 | if (!SCM_UNBNDP (end)) | |
715 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
1146b6cd | 716 | } |
35de7ebe | 717 | |
04b87de5 | 718 | ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, |
03a5397a MV |
719 | scm_from_size_t (base + cstart), |
720 | scm_from_size_t (base + cend)); | |
6c951427 | 721 | |
03a5397a MV |
722 | if (!scm_is_eq (cra, ura)) |
723 | scm_array_copy_x (cra, ura); | |
724 | return ans; | |
3d8d56df | 725 | } |
03a5397a MV |
726 | else |
727 | scm_wrong_type_arg_msg (NULL, 0, ura, "array"); | |
0f2d19dd | 728 | } |
1bbd0b84 | 729 | #undef FUNC_NAME |
0f2d19dd | 730 | |
3b3b36dd | 731 | SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, |
03a5397a | 732 | (SCM ura, SCM port_or_fd, SCM start, SCM end), |
b380b885 MD |
733 | "Writes all elements of @var{ura} as binary objects to\n" |
734 | "@var{port-or-fdes}.\n\n" | |
735 | "The optional arguments @var{start}\n" | |
736 | "and @var{end} allow\n" | |
737 | "a specified region of a vector (or linearized array) to be written.\n\n" | |
9401323e | 738 | "The number of objects actually written is returned.\n" |
b380b885 MD |
739 | "@var{port-or-fdes} may be\n" |
740 | "omitted, in which case it defaults to the value returned by\n" | |
741 | "@code{(current-output-port)}.") | |
1bbd0b84 | 742 | #define FUNC_NAME s_scm_uniform_array_write |
0f2d19dd | 743 | { |
3d8d56df | 744 | if (SCM_UNBNDP (port_or_fd)) |
9de87eea | 745 | port_or_fd = scm_current_output_port (); |
20930f28 | 746 | |
03a5397a | 747 | if (scm_is_uniform_vector (ura)) |
20930f28 | 748 | { |
03a5397a | 749 | return scm_uniform_vector_write (ura, port_or_fd, start, end); |
20930f28 | 750 | } |
04b87de5 | 751 | else if (SCM_I_ARRAYP (ura)) |
20930f28 | 752 | { |
03a5397a MV |
753 | size_t base, vlen, cstart, cend; |
754 | SCM cra, ans; | |
755 | ||
756 | cra = scm_ra2contig (ura, 1); | |
04b87de5 MV |
757 | base = SCM_I_ARRAY_BASE (cra); |
758 | vlen = SCM_I_ARRAY_DIMS (cra)->inc * | |
759 | (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); | |
1146b6cd | 760 | |
03a5397a MV |
761 | cstart = 0; |
762 | cend = vlen; | |
763 | if (!SCM_UNBNDP (start)) | |
1146b6cd | 764 | { |
03a5397a MV |
765 | cstart = scm_to_unsigned_integer (start, 0, vlen); |
766 | if (!SCM_UNBNDP (end)) | |
767 | cend = scm_to_unsigned_integer (end, cstart, vlen); | |
1146b6cd | 768 | } |
3d8d56df | 769 | |
04b87de5 | 770 | ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, |
03a5397a MV |
771 | scm_from_size_t (base + cstart), |
772 | scm_from_size_t (base + cend)); | |
6c951427 | 773 | |
03a5397a | 774 | return ans; |
3d8d56df | 775 | } |
03a5397a MV |
776 | else |
777 | scm_wrong_type_arg_msg (NULL, 0, ura, "array"); | |
0f2d19dd | 778 | } |
1bbd0b84 | 779 | #undef FUNC_NAME |
0f2d19dd JB |
780 | |
781 | ||
bcbbea0e | 782 | static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k); |
1cc91f1b | 783 | |
f301dbf3 | 784 | SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, |
2caaadd1 | 785 | (SCM type, SCM shape, SCM lst), |
f301dbf3 MV |
786 | "Return an array of the type @var{type}\n" |
787 | "with elements the same as those of @var{lst}.\n" | |
bfad4005 | 788 | "\n" |
2caaadd1 MV |
789 | "The argument @var{shape} determines the number of dimensions\n" |
790 | "of the array and their shape. It is either an exact integer,\n" | |
791 | "giving the\n" | |
792 | "number of dimensions directly, or a list whose length\n" | |
793 | "specifies the number of dimensions and each element specified\n" | |
794 | "the lower and optionally the upper bound of the corresponding\n" | |
795 | "dimension.\n" | |
796 | "When the element is list of two elements, these elements\n" | |
797 | "give the lower and upper bounds. When it is an exact\n" | |
798 | "integer, it gives only the lower bound.") | |
f301dbf3 | 799 | #define FUNC_NAME s_scm_list_to_typed_array |
0f2d19dd | 800 | { |
2caaadd1 | 801 | SCM row; |
0f2d19dd | 802 | SCM ra; |
bcbbea0e | 803 | scm_t_array_handle handle; |
bfad4005 | 804 | |
bfad4005 | 805 | row = lst; |
2caaadd1 | 806 | if (scm_is_integer (shape)) |
0f2d19dd | 807 | { |
2caaadd1 MV |
808 | size_t k = scm_to_size_t (shape); |
809 | shape = SCM_EOL; | |
bfad4005 MV |
810 | while (k-- > 0) |
811 | { | |
812 | shape = scm_cons (scm_length (row), shape); | |
2caaadd1 | 813 | if (k > 0 && !scm_is_null (row)) |
bfad4005 MV |
814 | row = scm_car (row); |
815 | } | |
816 | } | |
817 | else | |
818 | { | |
2caaadd1 MV |
819 | SCM shape_spec = shape; |
820 | shape = SCM_EOL; | |
bfad4005 MV |
821 | while (1) |
822 | { | |
2caaadd1 MV |
823 | SCM spec = scm_car (shape_spec); |
824 | if (scm_is_pair (spec)) | |
825 | shape = scm_cons (spec, shape); | |
826 | else | |
827 | shape = scm_cons (scm_list_2 (spec, | |
828 | scm_sum (scm_sum (spec, | |
829 | scm_length (row)), | |
830 | scm_from_int (-1))), | |
831 | shape); | |
832 | shape_spec = scm_cdr (shape_spec); | |
833 | if (scm_is_pair (shape_spec)) | |
834 | { | |
835 | if (!scm_is_null (row)) | |
836 | row = scm_car (row); | |
837 | } | |
bfad4005 MV |
838 | else |
839 | break; | |
840 | } | |
0f2d19dd | 841 | } |
bfad4005 | 842 | |
f0b91039 MV |
843 | ra = scm_make_typed_array (type, SCM_UNSPECIFIED, |
844 | scm_reverse_x (shape, SCM_EOL)); | |
20930f28 | 845 | |
bcbbea0e MV |
846 | scm_array_get_handle (ra, &handle); |
847 | l2ra (lst, &handle, 0, 0); | |
848 | scm_array_handle_release (&handle); | |
849 | ||
850 | return ra; | |
0f2d19dd | 851 | } |
1bbd0b84 | 852 | #undef FUNC_NAME |
0f2d19dd | 853 | |
f301dbf3 MV |
854 | SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, |
855 | (SCM ndim, SCM lst), | |
856 | "Return an array with elements the same as those of @var{lst}.") | |
857 | #define FUNC_NAME s_scm_list_to_array | |
858 | { | |
859 | return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); | |
860 | } | |
861 | #undef FUNC_NAME | |
862 | ||
bcbbea0e MV |
863 | static void |
864 | l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) | |
0f2d19dd | 865 | { |
bcbbea0e MV |
866 | if (k == scm_array_handle_rank (handle)) |
867 | scm_array_handle_set (handle, pos, lst); | |
0f2d19dd JB |
868 | else |
869 | { | |
bcbbea0e MV |
870 | scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; |
871 | ssize_t inc = dim->inc; | |
2caaadd1 MV |
872 | size_t len = 1 + dim->ubnd - dim->lbnd, n; |
873 | char *errmsg = NULL; | |
bcbbea0e | 874 | |
2caaadd1 | 875 | n = len; |
bcbbea0e | 876 | while (n > 0 && scm_is_pair (lst)) |
0f2d19dd | 877 | { |
bcbbea0e MV |
878 | l2ra (SCM_CAR (lst), handle, pos, k + 1); |
879 | pos += inc; | |
0f2d19dd | 880 | lst = SCM_CDR (lst); |
bcbbea0e | 881 | n -= 1; |
0f2d19dd | 882 | } |
bcbbea0e | 883 | if (n != 0) |
2caaadd1 | 884 | errmsg = "too few elements for array dimension ~a, need ~a"; |
d2e53ed6 | 885 | if (!scm_is_null (lst)) |
2caaadd1 MV |
886 | errmsg = "too many elements for array dimension ~a, want ~a"; |
887 | if (errmsg) | |
888 | scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k), | |
889 | scm_from_size_t (len))); | |
0f2d19dd | 890 | } |
0f2d19dd JB |
891 | } |
892 | ||
e0e49670 MV |
893 | /* Print dimension DIM of ARRAY. |
894 | */ | |
0f2d19dd | 895 | |
e0e49670 | 896 | static int |
66b9d7d3 | 897 | scm_i_print_array_dimension (SCM array, int dim, int base, |
e0e49670 MV |
898 | SCM port, scm_print_state *pstate) |
899 | { | |
04b87de5 | 900 | scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; |
e0e49670 MV |
901 | long idx; |
902 | ||
903 | scm_putc ('(', port); | |
904 | ||
e0e49670 MV |
905 | for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) |
906 | { | |
04b87de5 | 907 | if (dim < SCM_I_ARRAY_NDIM(array)-1) |
66b9d7d3 | 908 | scm_i_print_array_dimension (array, dim+1, base, |
02339e5b | 909 | port, pstate); |
e0e49670 | 910 | else |
66b9d7d3 | 911 | scm_iprin1 (scm_c_generalized_vector_ref (SCM_I_ARRAY_V (array), base), |
e0e49670 MV |
912 | port, pstate); |
913 | if (idx < dim_spec->ubnd) | |
914 | scm_putc (' ', port); | |
915 | base += dim_spec->inc; | |
916 | } | |
917 | ||
918 | scm_putc (')', port); | |
919 | return 1; | |
920 | } | |
921 | ||
f301dbf3 | 922 | /* Print an array. (Only for strict arrays, not for generalized vectors.) |
e0e49670 MV |
923 | */ |
924 | ||
e0e49670 MV |
925 | static int |
926 | scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) | |
927 | { | |
04b87de5 MV |
928 | long ndim = SCM_I_ARRAY_NDIM (array); |
929 | scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array); | |
930 | SCM v = SCM_I_ARRAY_V (array); | |
931 | unsigned long base = SCM_I_ARRAY_BASE (array); | |
e0e49670 | 932 | long i; |
2caaadd1 | 933 | int print_lbnds = 0, zero_size = 0, print_lens = 0; |
e0e49670 MV |
934 | |
935 | scm_putc ('#', port); | |
c0fc64c8 | 936 | if (ndim != 1 || dim_specs[0].lbnd != 0) |
e0e49670 | 937 | scm_intprint (ndim, 10, port); |
20930f28 MV |
938 | if (scm_is_uniform_vector (v)) |
939 | scm_puts (scm_i_uniform_vector_tag (v), port); | |
940 | else if (scm_is_bitvector (v)) | |
941 | scm_puts ("b", port); | |
942 | else if (scm_is_string (v)) | |
943 | scm_puts ("a", port); | |
944 | else if (!scm_is_vector (v)) | |
945 | scm_puts ("?", port); | |
946 | ||
e0e49670 | 947 | for (i = 0; i < ndim; i++) |
2caaadd1 MV |
948 | { |
949 | if (dim_specs[i].lbnd != 0) | |
950 | print_lbnds = 1; | |
951 | if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0) | |
952 | zero_size = 1; | |
953 | else if (zero_size) | |
954 | print_lens = 1; | |
955 | } | |
956 | ||
957 | if (print_lbnds || print_lens) | |
958 | for (i = 0; i < ndim; i++) | |
e0e49670 | 959 | { |
2caaadd1 | 960 | if (print_lbnds) |
e0e49670 MV |
961 | { |
962 | scm_putc ('@', port); | |
2caaadd1 MV |
963 | scm_intprint (dim_specs[i].lbnd, 10, port); |
964 | } | |
965 | if (print_lens) | |
966 | { | |
967 | scm_putc (':', port); | |
968 | scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1, | |
969 | 10, port); | |
e0e49670 | 970 | } |
e0e49670 MV |
971 | } |
972 | ||
5f37cb63 MV |
973 | if (ndim == 0) |
974 | { | |
975 | /* Rank zero arrays, which are really just scalars, are printed | |
976 | specially. The consequent way would be to print them as | |
977 | ||
978 | #0 OBJ | |
979 | ||
980 | where OBJ is the printed representation of the scalar, but we | |
981 | print them instead as | |
982 | ||
983 | #0(OBJ) | |
984 | ||
985 | to make them look less strange. | |
986 | ||
987 | Just printing them as | |
988 | ||
989 | OBJ | |
990 | ||
991 | would be correct in a way as well, but zero rank arrays are | |
992 | not really the same as Scheme values since they are boxed and | |
993 | can be modified with array-set!, say. | |
994 | */ | |
995 | scm_putc ('(', port); | |
66b9d7d3 | 996 | scm_iprin1 (scm_c_generalized_vector_ref (v, base), port, pstate); |
5f37cb63 MV |
997 | scm_putc (')', port); |
998 | return 1; | |
999 | } | |
1000 | else | |
66b9d7d3 | 1001 | return scm_i_print_array_dimension (array, 0, base, port, pstate); |
e0e49670 | 1002 | } |
1cc91f1b | 1003 | |
bfad4005 MV |
1004 | /* Read an array. This function can also read vectors and uniform |
1005 | vectors. Also, the conflict between '#f' and '#f32' and '#f64' is | |
1006 | handled here. | |
1007 | ||
1008 | C is the first character read after the '#'. | |
1009 | */ | |
1010 | ||
bfad4005 | 1011 | static SCM |
f301dbf3 | 1012 | tag_to_type (const char *tag, SCM port) |
bfad4005 | 1013 | { |
5f37cb63 MV |
1014 | if (*tag == '\0') |
1015 | return SCM_BOOL_T; | |
1016 | else | |
1017 | return scm_from_locale_symbol (tag); | |
bfad4005 MV |
1018 | } |
1019 | ||
2caaadd1 MV |
1020 | static int |
1021 | read_decimal_integer (SCM port, int c, ssize_t *resp) | |
1022 | { | |
1023 | ssize_t sign = 1; | |
1024 | ssize_t res = 0; | |
1025 | int got_it = 0; | |
1026 | ||
1027 | if (c == '-') | |
1028 | { | |
1029 | sign = -1; | |
1030 | c = scm_getc (port); | |
1031 | } | |
1032 | ||
1033 | while ('0' <= c && c <= '9') | |
1034 | { | |
1035 | res = 10*res + c-'0'; | |
1036 | got_it = 1; | |
1037 | c = scm_getc (port); | |
1038 | } | |
1039 | ||
1040 | if (got_it) | |
f30e1bdf | 1041 | *resp = sign * res; |
2caaadd1 MV |
1042 | return c; |
1043 | } | |
1044 | ||
bfad4005 MV |
1045 | SCM |
1046 | scm_i_read_array (SCM port, int c) | |
1047 | { | |
5a6d139b | 1048 | ssize_t rank; |
bfad4005 MV |
1049 | int got_rank; |
1050 | char tag[80]; | |
1051 | int tag_len; | |
1052 | ||
2caaadd1 | 1053 | SCM shape = SCM_BOOL_F, elements; |
bfad4005 MV |
1054 | |
1055 | /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but | |
1056 | the array code can not deal with zero-length dimensions yet, and | |
1057 | we want to allow zero-length vectors, of course. | |
1058 | */ | |
1059 | if (c == '(') | |
1060 | { | |
1061 | scm_ungetc (c, port); | |
1062 | return scm_vector (scm_read (port)); | |
1063 | } | |
1064 | ||
1065 | /* Disambiguate between '#f' and uniform floating point vectors. | |
1066 | */ | |
1067 | if (c == 'f') | |
1068 | { | |
1069 | c = scm_getc (port); | |
1070 | if (c != '3' && c != '6') | |
1071 | { | |
1072 | if (c != EOF) | |
1073 | scm_ungetc (c, port); | |
1074 | return SCM_BOOL_F; | |
1075 | } | |
1076 | rank = 1; | |
1077 | got_rank = 1; | |
1078 | tag[0] = 'f'; | |
1079 | tag_len = 1; | |
1080 | goto continue_reading_tag; | |
1081 | } | |
1082 | ||
2caaadd1 MV |
1083 | /* Read rank. |
1084 | */ | |
1085 | rank = 1; | |
1086 | c = read_decimal_integer (port, c, &rank); | |
1087 | if (rank < 0) | |
1088 | scm_i_input_error (NULL, port, "array rank must be non-negative", | |
1089 | SCM_EOL); | |
bfad4005 | 1090 | |
2caaadd1 MV |
1091 | /* Read tag. |
1092 | */ | |
bfad4005 MV |
1093 | tag_len = 0; |
1094 | continue_reading_tag: | |
2caaadd1 | 1095 | while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80) |
bfad4005 MV |
1096 | { |
1097 | tag[tag_len++] = c; | |
1098 | c = scm_getc (port); | |
1099 | } | |
1100 | tag[tag_len] = '\0'; | |
1101 | ||
2caaadd1 MV |
1102 | /* Read shape. |
1103 | */ | |
1104 | if (c == '@' || c == ':') | |
bfad4005 | 1105 | { |
2caaadd1 | 1106 | shape = SCM_EOL; |
5f37cb63 MV |
1107 | |
1108 | do | |
bfad4005 | 1109 | { |
2caaadd1 MV |
1110 | ssize_t lbnd = 0, len = 0; |
1111 | SCM s; | |
5f37cb63 | 1112 | |
2caaadd1 | 1113 | if (c == '@') |
5f37cb63 | 1114 | { |
5f37cb63 | 1115 | c = scm_getc (port); |
2caaadd1 | 1116 | c = read_decimal_integer (port, c, &lbnd); |
5f37cb63 | 1117 | } |
2caaadd1 MV |
1118 | |
1119 | s = scm_from_ssize_t (lbnd); | |
1120 | ||
1121 | if (c == ':') | |
5f37cb63 | 1122 | { |
5f37cb63 | 1123 | c = scm_getc (port); |
2caaadd1 | 1124 | c = read_decimal_integer (port, c, &len); |
f30e1bdf LC |
1125 | if (len < 0) |
1126 | scm_i_input_error (NULL, port, | |
1127 | "array length must be non-negative", | |
1128 | SCM_EOL); | |
1129 | ||
2caaadd1 | 1130 | s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); |
5f37cb63 | 1131 | } |
2caaadd1 MV |
1132 | |
1133 | shape = scm_cons (s, shape); | |
1134 | } while (c == '@' || c == ':'); | |
1135 | ||
1136 | shape = scm_reverse_x (shape, SCM_EOL); | |
bfad4005 MV |
1137 | } |
1138 | ||
1139 | /* Read nested lists of elements. | |
1140 | */ | |
1141 | if (c != '(') | |
1142 | scm_i_input_error (NULL, port, | |
1143 | "missing '(' in vector or array literal", | |
1144 | SCM_EOL); | |
1145 | scm_ungetc (c, port); | |
1146 | elements = scm_read (port); | |
1147 | ||
2caaadd1 | 1148 | if (scm_is_false (shape)) |
5a6d139b | 1149 | shape = scm_from_ssize_t (rank); |
2caaadd1 MV |
1150 | else if (scm_ilength (shape) != rank) |
1151 | scm_i_input_error | |
1152 | (NULL, port, | |
1153 | "the number of shape specifications must match the array rank", | |
1154 | SCM_EOL); | |
bfad4005 | 1155 | |
5f37cb63 MV |
1156 | /* Handle special print syntax of rank zero arrays; see |
1157 | scm_i_print_array for a rationale. | |
1158 | */ | |
1159 | if (rank == 0) | |
2caaadd1 MV |
1160 | { |
1161 | if (!scm_is_pair (elements)) | |
1162 | scm_i_input_error (NULL, port, | |
1163 | "too few elements in array literal, need 1", | |
1164 | SCM_EOL); | |
1165 | if (!scm_is_null (SCM_CDR (elements))) | |
1166 | scm_i_input_error (NULL, port, | |
1167 | "too many elements in array literal, want 1", | |
1168 | SCM_EOL); | |
1169 | elements = SCM_CAR (elements); | |
1170 | } | |
5f37cb63 MV |
1171 | |
1172 | /* Construct array. | |
1173 | */ | |
2caaadd1 | 1174 | return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); |
bfad4005 MV |
1175 | } |
1176 | ||
ab1be174 | 1177 | |
0f2d19dd | 1178 | static SCM |
e841c3e0 | 1179 | array_mark (SCM ptr) |
0f2d19dd | 1180 | { |
04b87de5 | 1181 | return SCM_I_ARRAY_V (ptr); |
0f2d19dd JB |
1182 | } |
1183 | ||
1be6b49c | 1184 | static size_t |
e841c3e0 | 1185 | array_free (SCM ptr) |
0f2d19dd | 1186 | { |
04b87de5 MV |
1187 | scm_gc_free (SCM_I_ARRAY_MEM (ptr), |
1188 | (sizeof (scm_i_t_array) | |
1189 | + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), | |
4c9419ac MV |
1190 | "array"); |
1191 | return 0; | |
0f2d19dd JB |
1192 | } |
1193 | ||
2a610be5 AW |
1194 | static SCM |
1195 | array_handle_ref (scm_t_array_handle *h, size_t pos) | |
1196 | { | |
1197 | return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos); | |
1198 | } | |
1199 | ||
1200 | static void | |
1201 | array_handle_set (scm_t_array_handle *h, size_t pos, SCM val) | |
1202 | { | |
1203 | scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val); | |
1204 | } | |
1205 | ||
1206 | /* FIXME: should be handle for vect? maybe not, because of dims */ | |
1207 | static void | |
1208 | array_get_handle (SCM array, scm_t_array_handle *h) | |
1209 | { | |
1210 | scm_t_array_handle vh; | |
1211 | scm_array_get_handle (SCM_I_ARRAY_V (array), &vh); | |
1212 | h->element_type = vh.element_type; | |
1213 | h->elements = vh.elements; | |
1214 | h->writable_elements = vh.writable_elements; | |
1215 | scm_array_handle_release (&vh); | |
1216 | ||
1217 | h->dims = SCM_I_ARRAY_DIMS (array); | |
1218 | h->ndims = SCM_I_ARRAY_NDIM (array); | |
1219 | h->base = SCM_I_ARRAY_BASE (array); | |
1220 | } | |
1221 | ||
1222 | SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff, | |
1223 | array_handle_ref, array_handle_set, | |
1224 | array_get_handle); | |
1225 | ||
0f2d19dd | 1226 | void |
2fa901a5 | 1227 | scm_init_arrays () |
0f2d19dd | 1228 | { |
04b87de5 MV |
1229 | scm_i_tc16_array = scm_make_smob_type ("array", 0); |
1230 | scm_set_smob_mark (scm_i_tc16_array, array_mark); | |
1231 | scm_set_smob_free (scm_i_tc16_array, array_free); | |
1232 | scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); | |
1233 | scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); | |
1234 | ||
0f2d19dd | 1235 | scm_add_feature ("array"); |
20930f28 | 1236 | |
f301dbf3 MV |
1237 | init_type_creator_table (); |
1238 | ||
2fa901a5 | 1239 | #include "libguile/arrays.x" |
bfad4005 | 1240 | |
0f2d19dd | 1241 | } |
89e00824 ML |
1242 | |
1243 | /* | |
1244 | Local Variables: | |
1245 | c-file-style: "gnu" | |
1246 | End: | |
1247 | */ |