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