1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
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.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
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
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/__scm.h"
32 #include "libguile/eq.h"
33 #include "libguile/chars.h"
34 #include "libguile/eval.h"
35 #include "libguile/fports.h"
36 #include "libguile/feature.h"
37 #include "libguile/root.h"
38 #include "libguile/strings.h"
39 #include "libguile/srfi-13.h"
40 #include "libguile/srfi-4.h"
41 #include "libguile/vectors.h"
42 #include "libguile/bitvectors.h"
43 #include "libguile/bytevectors.h"
44 #include "libguile/list.h"
45 #include "libguile/dynwind.h"
46 #include "libguile/read.h"
48 #include "libguile/validate.h"
49 #include "libguile/arrays.h"
50 #include "libguile/array-map.h"
51 #include "libguile/generalized-vectors.h"
52 #include "libguile/generalized-arrays.h"
53 #include "libguile/uniform.h"
56 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
57 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
58 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
59 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
62 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
64 "Return the root vector of a shared array.")
65 #define FUNC_NAME s_scm_shared_array_root
67 if (SCM_I_ARRAYP (ra
))
68 return SCM_I_ARRAY_V (ra
);
69 else if (scm_is_generalized_vector (ra
))
71 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
76 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
78 "Return the root vector index of the first element in the array.")
79 #define FUNC_NAME s_scm_shared_array_offset
81 scm_t_array_handle handle
;
84 scm_array_get_handle (ra
, &handle
);
85 res
= scm_from_size_t (handle
.base
);
86 scm_array_handle_release (&handle
);
92 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
94 "For each dimension, return the distance between elements in the root vector.")
95 #define FUNC_NAME s_scm_shared_array_increments
97 scm_t_array_handle handle
;
102 scm_array_get_handle (ra
, &handle
);
103 k
= scm_array_handle_rank (&handle
);
104 s
= scm_array_handle_dims (&handle
);
106 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
107 scm_array_handle_release (&handle
);
113 scm_i_make_array (int ndim
)
116 ra
= scm_cell (((scm_t_bits
) ndim
<< 17) + scm_tc7_array
,
117 (scm_t_bits
) scm_gc_malloc (sizeof (scm_i_t_array
) +
118 ndim
* sizeof (scm_t_array_dim
),
120 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
124 static char s_bad_spec
[] = "Bad scm_array dimension";
127 /* Increments will still need to be set. */
130 scm_i_shap2ra (SCM args
)
134 int ndim
= scm_ilength (args
);
136 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
138 ra
= scm_i_make_array (ndim
);
139 SCM_I_ARRAY_BASE (ra
) = 0;
140 s
= SCM_I_ARRAY_DIMS (ra
);
141 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
143 spec
= SCM_CAR (args
);
144 if (scm_is_integer (spec
))
146 if (scm_to_long (spec
) < 0)
147 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
149 s
->ubnd
= scm_to_long (spec
) - 1;
154 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
155 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
156 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
158 if (!scm_is_pair (sp
)
159 || !scm_is_integer (SCM_CAR (sp
))
160 || !scm_is_null (SCM_CDR (sp
)))
161 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
162 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
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
178 ra
= scm_i_shap2ra (bounds
);
179 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
180 s
= SCM_I_ARRAY_DIMS (ra
);
181 k
= SCM_I_ARRAY_NDIM (ra
);
186 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
187 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
190 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
191 fill
= SCM_UNDEFINED
;
194 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), fill
);
196 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
197 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
198 return SCM_I_ARRAY_V (ra
);
204 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
206 #define FUNC_NAME "scm_from_contiguous_typed_array"
211 scm_t_array_handle h
;
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
);
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
;
227 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), SCM_UNDEFINED
);
230 scm_array_get_handle (ra
, &h
);
231 elts
= h
.writable_elements
;
232 sz
= scm_array_handle_uniform_element_bit_size (&h
);
233 scm_array_handle_release (&h
);
235 if (sz
>= 8 && ((sz
% 8) == 0))
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
);
244 /* byte_len ?= ceil (rlen * sz / 8) */
245 if (byte_len
!= (rlen
* sz
+ 7) / 8)
246 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
249 /* an internal guile error, really */
250 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
252 memcpy (elts
, bytes
, byte_len
);
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
);
262 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
263 #define FUNC_NAME "scm_from_contiguous_array"
268 scm_t_array_handle h
;
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
);
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
;
282 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
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
);
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
);
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
301 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
306 scm_i_ra_set_contp (SCM ra
)
308 size_t k
= SCM_I_ARRAY_NDIM (ra
);
311 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
314 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
316 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
319 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
320 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
323 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
327 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
328 (SCM oldra
, SCM mapfunc
, SCM dims
),
329 "@code{make-shared-array} can be used to create shared subarrays\n"
330 "of other arrays. The @var{mapfunc} is a function that\n"
331 "translates coordinates in the new array into coordinates in the\n"
332 "old array. A @var{mapfunc} must be linear, and its range must\n"
333 "stay within the bounds of the old array, but it can be\n"
334 "otherwise arbitrary. A simple example:\n"
336 "(define fred (make-array #f 8 8))\n"
337 "(define freds-diagonal\n"
338 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
339 "(array-set! freds-diagonal 'foo 3)\n"
340 "(array-ref fred 3 3) @result{} foo\n"
341 "(define freds-center\n"
342 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
343 "(array-ref freds-center 0 0) @result{} foo\n"
345 #define FUNC_NAME s_scm_make_shared_array
347 scm_t_array_handle old_handle
;
353 long old_base
, old_min
, new_min
, old_max
, new_max
;
356 SCM_VALIDATE_REST_ARGUMENT (dims
);
357 SCM_VALIDATE_PROC (2, mapfunc
);
358 ra
= scm_i_shap2ra (dims
);
360 scm_array_get_handle (oldra
, &old_handle
);
362 if (SCM_I_ARRAYP (oldra
))
364 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
365 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
366 s
= scm_array_handle_dims (&old_handle
);
367 k
= scm_array_handle_rank (&old_handle
);
371 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
373 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
378 SCM_I_ARRAY_V (ra
) = oldra
;
379 old_base
= old_min
= 0;
380 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
384 s
= SCM_I_ARRAY_DIMS (ra
);
385 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
387 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
388 if (s
[k
].ubnd
< s
[k
].lbnd
)
390 if (1 == SCM_I_ARRAY_NDIM (ra
))
391 ra
= scm_make_generalized_vector (scm_array_type (ra
),
392 SCM_INUM0
, SCM_UNDEFINED
);
395 scm_make_generalized_vector (scm_array_type (ra
),
396 SCM_INUM0
, SCM_UNDEFINED
);
397 scm_array_handle_release (&old_handle
);
402 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
403 i
= scm_array_handle_pos (&old_handle
, imap
);
404 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
406 k
= SCM_I_ARRAY_NDIM (ra
);
409 if (s
[k
].ubnd
> s
[k
].lbnd
)
411 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
412 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
413 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
416 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
418 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
421 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
422 indptr
= SCM_CDR (indptr
);
425 scm_array_handle_release (&old_handle
);
427 if (old_min
> new_min
|| old_max
< new_max
)
428 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
429 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
431 SCM v
= SCM_I_ARRAY_V (ra
);
432 size_t length
= scm_c_generalized_vector_length (v
);
433 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
435 if (s
->ubnd
< s
->lbnd
)
436 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
439 scm_i_ra_set_contp (ra
);
445 /* args are RA . DIMS */
446 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
448 "Return an array sharing contents with @var{ra}, but with\n"
449 "dimensions arranged in a different order. There must be one\n"
450 "@var{dim} argument for each dimension of @var{ra}.\n"
451 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
452 "and the rank of the array to be returned. Each integer in that\n"
453 "range must appear at least once in the argument list.\n"
455 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
456 "dimensions in the array to be returned, their positions in the\n"
457 "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
458 "may have the same value, in which case the returned array will\n"
459 "have smaller rank than @var{ra}.\n"
462 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
463 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
464 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
465 " #2((a 4) (b 5) (c 6))\n"
467 #define FUNC_NAME s_scm_transpose_array
470 scm_t_array_dim
*s
, *r
;
473 SCM_VALIDATE_REST_ARGUMENT (args
);
474 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
476 if (scm_is_generalized_vector (ra
))
478 /* Make sure that we are called with a single zero as
481 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
482 SCM_WRONG_NUM_ARGS ();
483 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
484 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
488 if (SCM_I_ARRAYP (ra
))
490 vargs
= scm_vector (args
);
491 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
492 SCM_WRONG_NUM_ARGS ();
494 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
496 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
497 0, SCM_I_ARRAY_NDIM(ra
));
502 res
= scm_i_make_array (ndim
);
503 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
504 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
507 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
508 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
510 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
512 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
513 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
514 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
515 if (r
->ubnd
< r
->lbnd
)
524 if (r
->ubnd
> s
->ubnd
)
526 if (r
->lbnd
< s
->lbnd
)
528 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
535 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
536 scm_i_ra_set_contp (res
);
540 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
544 /* attempts to unroll an array into a one-dimensional array.
545 returns the unrolled array or #f if it can't be done. */
546 /* if strict is not SCM_UNDEFINED, return #f if returned array
547 wouldn't have contiguous elements. */
548 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
549 (SCM ra
, SCM strict
),
550 "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
551 "array without changing their order (last subscript changing\n"
552 "fastest), then @code{array-contents} returns that shared array,\n"
553 "otherwise it returns @code{#f}. All arrays made by\n"
554 "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
555 "some arrays made by @code{make-shared-array} may not be. If\n"
556 "the optional argument @var{strict} is provided, a shared array\n"
557 "will be returned only if its elements are stored internally\n"
558 "contiguous in memory.")
559 #define FUNC_NAME s_scm_array_contents
563 if (scm_is_generalized_vector (ra
))
566 if (SCM_I_ARRAYP (ra
))
568 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
569 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
571 for (k
= 0; k
< ndim
; k
++)
572 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
573 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
575 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
577 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
579 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
580 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
587 SCM v
= SCM_I_ARRAY_V (ra
);
588 size_t length
= scm_c_generalized_vector_length (v
);
589 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
593 sra
= scm_i_make_array (1);
594 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
595 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
596 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
597 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
598 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
602 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
608 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
610 if (k
== scm_array_handle_rank (handle
))
611 scm_array_handle_set (handle
, pos
, lst
);
614 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
615 ssize_t inc
= dim
->inc
;
616 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
620 while (n
> 0 && scm_is_pair (lst
))
622 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
628 errmsg
= "too few elements for array dimension ~a, need ~a";
629 if (!scm_is_null (lst
))
630 errmsg
= "too many elements for array dimension ~a, want ~a";
632 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
633 scm_from_size_t (len
)));
638 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
639 (SCM type
, SCM shape
, SCM lst
),
640 "Return an array of the type @var{type}\n"
641 "with elements the same as those of @var{lst}.\n"
643 "The argument @var{shape} determines the number of dimensions\n"
644 "of the array and their shape. It is either an exact integer,\n"
646 "number of dimensions directly, or a list whose length\n"
647 "specifies the number of dimensions and each element specified\n"
648 "the lower and optionally the upper bound of the corresponding\n"
650 "When the element is list of two elements, these elements\n"
651 "give the lower and upper bounds. When it is an exact\n"
652 "integer, it gives only the lower bound.")
653 #define FUNC_NAME s_scm_list_to_typed_array
657 scm_t_array_handle handle
;
660 if (scm_is_integer (shape
))
662 size_t k
= scm_to_size_t (shape
);
666 shape
= scm_cons (scm_length (row
), shape
);
667 if (k
> 0 && !scm_is_null (row
))
673 SCM shape_spec
= shape
;
677 SCM spec
= scm_car (shape_spec
);
678 if (scm_is_pair (spec
))
679 shape
= scm_cons (spec
, shape
);
681 shape
= scm_cons (scm_list_2 (spec
,
682 scm_sum (scm_sum (spec
,
686 shape_spec
= scm_cdr (shape_spec
);
687 if (scm_is_pair (shape_spec
))
689 if (!scm_is_null (row
))
697 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
698 scm_reverse_x (shape
, SCM_EOL
));
700 scm_array_get_handle (ra
, &handle
);
701 list_to_array (lst
, &handle
, 0, 0);
702 scm_array_handle_release (&handle
);
708 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
710 "Return an array with elements the same as those of @var{lst}.")
711 #define FUNC_NAME s_scm_list_to_array
713 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
717 /* Print dimension DIM of ARRAY.
721 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
722 SCM port
, scm_print_state
*pstate
)
725 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
729 scm_putc ('(', port
);
730 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
731 i
++, pos
+= h
->dims
[dim
].inc
)
733 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
734 if (i
< h
->dims
[dim
].ubnd
)
735 scm_putc (' ', port
);
737 scm_putc (')', port
);
746 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
748 scm_t_array_handle h
;
750 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
752 scm_array_get_handle (array
, &h
);
754 scm_putc ('#', port
);
755 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
756 scm_intprint (h
.ndims
, 10, port
);
757 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
758 scm_write (scm_array_handle_element_type (&h
), port
);
760 for (i
= 0; i
< h
.ndims
; i
++)
762 if (h
.dims
[i
].lbnd
!= 0)
764 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
770 if (print_lbnds
|| print_lens
)
771 for (i
= 0; i
< h
.ndims
; i
++)
775 scm_putc ('@', port
);
776 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
780 scm_putc (':', port
);
781 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
788 /* Rank zero arrays, which are really just scalars, are printed
789 specially. The consequent way would be to print them as
793 where OBJ is the printed representation of the scalar, but we
794 print them instead as
798 to make them look less strange.
800 Just printing them as
804 would be correct in a way as well, but zero rank arrays are
805 not really the same as Scheme values since they are boxed and
806 can be modified with array-set!, say.
808 scm_putc ('(', port
);
809 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
810 scm_putc (')', port
);
814 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
817 /* Read an array. This function can also read vectors and uniform
818 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
821 C is the first character read after the '#'.
825 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
837 while ('0' <= c
&& c
<= '9')
839 res
= 10*res
+ c
-'0';
850 scm_i_read_array (SCM port
, int c
)
853 scm_t_wchar tag_buf
[8];
856 SCM tag
, shape
= SCM_BOOL_F
, elements
;
858 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
859 the array code can not deal with zero-length dimensions yet, and
860 we want to allow zero-length vectors, of course.
864 scm_ungetc (c
, port
);
865 return scm_vector (scm_read (port
));
868 /* Disambiguate between '#f' and uniform floating point vectors.
873 if (c
!= '3' && c
!= '6')
876 scm_ungetc (c
, port
);
882 goto continue_reading_tag
;
888 c
= read_decimal_integer (port
, c
, &rank
);
890 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
896 continue_reading_tag
:
897 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':'
898 && tag_len
< sizeof tag_buf
/ sizeof tag_buf
[0])
900 tag_buf
[tag_len
++] = c
;
907 tag
= scm_string_to_symbol (scm_from_utf32_stringn (tag_buf
, tag_len
));
908 if (tag_len
== sizeof tag_buf
/ sizeof tag_buf
[0])
909 scm_i_input_error (NULL
, port
, "invalid array tag, starting with: ~a",
915 if (c
== '@' || c
== ':')
921 ssize_t lbnd
= 0, len
= 0;
927 c
= read_decimal_integer (port
, c
, &lbnd
);
930 s
= scm_from_ssize_t (lbnd
);
935 c
= read_decimal_integer (port
, c
, &len
);
937 scm_i_input_error (NULL
, port
,
938 "array length must be non-negative",
941 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
944 shape
= scm_cons (s
, shape
);
945 } while (c
== '@' || c
== ':');
947 shape
= scm_reverse_x (shape
, SCM_EOL
);
950 /* Read nested lists of elements.
953 scm_i_input_error (NULL
, port
,
954 "missing '(' in vector or array literal",
956 scm_ungetc (c
, port
);
957 elements
= scm_read (port
);
959 if (scm_is_false (shape
))
960 shape
= scm_from_ssize_t (rank
);
961 else if (scm_ilength (shape
) != rank
)
964 "the number of shape specifications must match the array rank",
967 /* Handle special print syntax of rank zero arrays; see
968 scm_i_print_array for a rationale.
972 if (!scm_is_pair (elements
))
973 scm_i_input_error (NULL
, port
,
974 "too few elements in array literal, need 1",
976 if (!scm_is_null (SCM_CDR (elements
)))
977 scm_i_input_error (NULL
, port
,
978 "too many elements in array literal, want 1",
980 elements
= SCM_CAR (elements
);
985 return scm_list_to_typed_array (tag
, shape
, elements
);
990 array_handle_ref (scm_t_array_handle
*h
, size_t pos
)
992 return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h
->array
), pos
);
996 array_handle_set (scm_t_array_handle
*h
, size_t pos
, SCM val
)
998 scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
1001 /* FIXME: should be handle for vect? maybe not, because of dims */
1003 array_get_handle (SCM array
, scm_t_array_handle
*h
)
1005 scm_t_array_handle vh
;
1006 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
1007 h
->element_type
= vh
.element_type
;
1008 h
->elements
= vh
.elements
;
1009 h
->writable_elements
= vh
.writable_elements
;
1010 scm_array_handle_release (&vh
);
1012 h
->dims
= SCM_I_ARRAY_DIMS (array
);
1013 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
1014 h
->base
= SCM_I_ARRAY_BASE (array
);
1017 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array
,
1019 array_handle_ref
, array_handle_set
,
1025 scm_add_feature ("array");
1027 #include "libguile/arrays.x"