1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
2 * 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
32 #include "libguile/_scm.h"
33 #include "libguile/__scm.h"
34 #include "libguile/eq.h"
35 #include "libguile/chars.h"
36 #include "libguile/eval.h"
37 #include "libguile/fports.h"
38 #include "libguile/feature.h"
39 #include "libguile/root.h"
40 #include "libguile/strings.h"
41 #include "libguile/srfi-13.h"
42 #include "libguile/srfi-4.h"
43 #include "libguile/vectors.h"
44 #include "libguile/bitvectors.h"
45 #include "libguile/bytevectors.h"
46 #include "libguile/list.h"
47 #include "libguile/dynwind.h"
48 #include "libguile/read.h"
50 #include "libguile/validate.h"
51 #include "libguile/arrays.h"
52 #include "libguile/array-map.h"
53 #include "libguile/generalized-vectors.h"
54 #include "libguile/generalized-arrays.h"
55 #include "libguile/uniform.h"
58 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
59 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
60 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
61 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
64 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
66 "Return the root vector of a shared array.")
67 #define FUNC_NAME s_scm_shared_array_root
69 if (!scm_is_array (ra
))
70 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
71 else if (SCM_I_ARRAYP (ra
))
72 return SCM_I_ARRAY_V (ra
);
79 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
81 "Return the root vector index of the first element in the array.")
82 #define FUNC_NAME s_scm_shared_array_offset
84 scm_t_array_handle handle
;
87 scm_array_get_handle (ra
, &handle
);
88 res
= scm_from_size_t (handle
.base
);
89 scm_array_handle_release (&handle
);
95 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
97 "For each dimension, return the distance between elements in the root vector.")
98 #define FUNC_NAME s_scm_shared_array_increments
100 scm_t_array_handle handle
;
105 scm_array_get_handle (ra
, &handle
);
106 k
= scm_array_handle_rank (&handle
);
107 s
= scm_array_handle_dims (&handle
);
109 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
110 scm_array_handle_release (&handle
);
116 scm_i_make_array (int ndim
)
119 ra
= scm_cell (((scm_t_bits
) ndim
<< 17) + scm_tc7_array
,
120 (scm_t_bits
) scm_gc_malloc (sizeof (scm_i_t_array
) +
121 ndim
* sizeof (scm_t_array_dim
),
123 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
127 static char s_bad_spec
[] = "Bad scm_array dimension";
130 /* Increments will still need to be set. */
133 scm_i_shap2ra (SCM args
)
137 int ndim
= scm_ilength (args
);
139 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
141 ra
= scm_i_make_array (ndim
);
142 SCM_I_ARRAY_BASE (ra
) = 0;
143 s
= SCM_I_ARRAY_DIMS (ra
);
144 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
146 spec
= SCM_CAR (args
);
147 if (scm_is_integer (spec
))
149 if (scm_to_long (spec
) < 0)
150 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
152 s
->ubnd
= scm_to_long (spec
) - 1;
157 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
158 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
159 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
161 if (!scm_is_pair (sp
)
162 || !scm_is_integer (SCM_CAR (sp
))
163 || !scm_is_null (SCM_CDR (sp
)))
164 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
165 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
172 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
173 (SCM type
, SCM fill
, SCM bounds
),
174 "Create and return an array of type @var{type}.")
175 #define FUNC_NAME s_scm_make_typed_array
181 ra
= scm_i_shap2ra (bounds
);
182 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
183 s
= SCM_I_ARRAY_DIMS (ra
);
184 k
= SCM_I_ARRAY_NDIM (ra
);
189 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
190 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
193 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
194 fill
= SCM_UNDEFINED
;
197 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), fill
);
199 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
201 return SCM_I_ARRAY_V (ra
);
208 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
210 #define FUNC_NAME "scm_from_contiguous_typed_array"
215 scm_t_array_handle h
;
219 ra
= scm_i_shap2ra (bounds
);
220 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
221 s
= SCM_I_ARRAY_DIMS (ra
);
222 k
= SCM_I_ARRAY_NDIM (ra
);
227 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
228 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
231 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), SCM_UNDEFINED
);
234 scm_array_get_handle (ra
, &h
);
235 elts
= h
.writable_elements
;
236 sz
= scm_array_handle_uniform_element_bit_size (&h
);
237 scm_array_handle_release (&h
);
239 if (sz
>= 8 && ((sz
% 8) == 0))
241 if (byte_len
% (sz
/ 8))
242 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
243 if (byte_len
/ (sz
/ 8) != rlen
)
244 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
248 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
250 if (byte_len
!= ((rlen
* sz
+ 31) / 32) * 4)
251 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
254 /* an internal guile error, really */
255 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
257 memcpy (elts
, bytes
, byte_len
);
259 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
261 return SCM_I_ARRAY_V (ra
);
267 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
268 #define FUNC_NAME "scm_from_contiguous_array"
273 scm_t_array_handle h
;
275 ra
= scm_i_shap2ra (bounds
);
276 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
277 s
= SCM_I_ARRAY_DIMS (ra
);
278 k
= SCM_I_ARRAY_NDIM (ra
);
283 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
284 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
287 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
289 SCM_I_ARRAY_V (ra
) = scm_c_make_vector (rlen
, SCM_UNDEFINED
);
290 scm_array_get_handle (ra
, &h
);
291 memcpy (h
.writable_elements
, elts
, rlen
* sizeof(SCM
));
292 scm_array_handle_release (&h
);
294 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
296 return SCM_I_ARRAY_V (ra
);
301 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
302 (SCM fill
, SCM bounds
),
303 "Create and return an array.")
304 #define FUNC_NAME s_scm_make_array
306 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
311 scm_i_ra_set_contp (SCM ra
)
313 size_t k
= SCM_I_ARRAY_NDIM (ra
);
316 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
319 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
321 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
324 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
325 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
328 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
332 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
333 (SCM oldra
, SCM mapfunc
, SCM dims
),
334 "@code{make-shared-array} can be used to create shared subarrays\n"
335 "of other arrays. The @var{mapfunc} is a function that\n"
336 "translates coordinates in the new array into coordinates in the\n"
337 "old array. A @var{mapfunc} must be linear, and its range must\n"
338 "stay within the bounds of the old array, but it can be\n"
339 "otherwise arbitrary. A simple example:\n"
341 "(define fred (make-array #f 8 8))\n"
342 "(define freds-diagonal\n"
343 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
344 "(array-set! freds-diagonal 'foo 3)\n"
345 "(array-ref fred 3 3) @result{} foo\n"
346 "(define freds-center\n"
347 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
348 "(array-ref freds-center 0 0) @result{} foo\n"
350 #define FUNC_NAME s_scm_make_shared_array
352 scm_t_array_handle old_handle
;
358 long old_base
, old_min
, new_min
, old_max
, new_max
;
361 SCM_VALIDATE_REST_ARGUMENT (dims
);
362 SCM_VALIDATE_PROC (2, mapfunc
);
363 ra
= scm_i_shap2ra (dims
);
365 scm_array_get_handle (oldra
, &old_handle
);
367 if (SCM_I_ARRAYP (oldra
))
369 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
370 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
371 s
= scm_array_handle_dims (&old_handle
);
372 k
= scm_array_handle_rank (&old_handle
);
376 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
378 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
383 SCM_I_ARRAY_V (ra
) = oldra
;
384 old_base
= old_min
= 0;
385 old_max
= scm_c_array_length (oldra
) - 1;
389 s
= SCM_I_ARRAY_DIMS (ra
);
390 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
392 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
393 if (s
[k
].ubnd
< s
[k
].lbnd
)
395 if (1 == SCM_I_ARRAY_NDIM (ra
))
396 ra
= scm_make_generalized_vector (scm_array_type (ra
),
397 SCM_INUM0
, SCM_UNDEFINED
);
400 scm_make_generalized_vector (scm_array_type (ra
),
401 SCM_INUM0
, SCM_UNDEFINED
);
402 scm_array_handle_release (&old_handle
);
407 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
408 i
= scm_array_handle_pos (&old_handle
, imap
);
409 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
411 k
= SCM_I_ARRAY_NDIM (ra
);
414 if (s
[k
].ubnd
> s
[k
].lbnd
)
416 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
417 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
418 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
421 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
423 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
426 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
427 indptr
= SCM_CDR (indptr
);
430 scm_array_handle_release (&old_handle
);
432 if (old_min
> new_min
|| old_max
< new_max
)
433 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
434 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
436 SCM v
= SCM_I_ARRAY_V (ra
);
437 size_t length
= scm_c_array_length (v
);
438 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
440 if (s
->ubnd
< s
->lbnd
)
441 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
444 scm_i_ra_set_contp (ra
);
450 /* args are RA . DIMS */
451 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
453 "Return an array sharing contents with @var{ra}, but with\n"
454 "dimensions arranged in a different order. There must be one\n"
455 "@var{dim} argument for each dimension of @var{ra}.\n"
456 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
457 "and the rank of the array to be returned. Each integer in that\n"
458 "range must appear at least once in the argument list.\n"
460 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
461 "dimensions in the array to be returned, their positions in the\n"
462 "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
463 "may have the same value, in which case the returned array will\n"
464 "have smaller rank than @var{ra}.\n"
467 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
468 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
469 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
470 " #2((a 4) (b 5) (c 6))\n"
472 #define FUNC_NAME s_scm_transpose_array
475 scm_t_array_dim
*s
, *r
;
478 SCM_VALIDATE_REST_ARGUMENT (args
);
479 SCM_ASSERT (SCM_HEAP_OBJECT_P (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
481 switch (scm_c_array_rank (ra
))
484 if (!scm_is_null (args
))
485 SCM_WRONG_NUM_ARGS ();
488 /* Make sure that we are called with a single zero as
491 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
492 SCM_WRONG_NUM_ARGS ();
493 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
494 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
497 vargs
= scm_vector (args
);
498 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
499 SCM_WRONG_NUM_ARGS ();
501 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
503 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
504 0, SCM_I_ARRAY_NDIM(ra
));
509 res
= scm_i_make_array (ndim
);
510 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
511 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
514 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
515 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
517 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
519 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
520 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
521 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
522 if (r
->ubnd
< r
->lbnd
)
531 if (r
->ubnd
> s
->ubnd
)
533 if (r
->lbnd
< s
->lbnd
)
535 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
542 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
543 scm_i_ra_set_contp (res
);
549 /* attempts to unroll an array into a one-dimensional array.
550 returns the unrolled array or #f if it can't be done. */
551 /* if strict is not SCM_UNDEFINED, return #f if returned array
552 wouldn't have contiguous elements. */
553 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
554 (SCM ra
, SCM strict
),
555 "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
556 "array without changing their order (last subscript changing\n"
557 "fastest), then @code{array-contents} returns that shared array,\n"
558 "otherwise it returns @code{#f}. All arrays made by\n"
559 "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
560 "some arrays made by @code{make-shared-array} may not be. If\n"
561 "the optional argument @var{strict} is provided, a shared array\n"
562 "will be returned only if its elements are stored internally\n"
563 "contiguous in memory.")
564 #define FUNC_NAME s_scm_array_contents
566 if (!scm_is_array (ra
))
567 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
568 else if (SCM_I_ARRAYP (ra
))
571 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
572 if (!SCM_I_ARRAY_CONTP (ra
))
574 for (k
= 0; k
< ndim
; k
++)
575 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
576 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
578 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
580 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
582 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
583 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
589 v
= SCM_I_ARRAY_V (ra
);
590 if ((len
== scm_c_array_length (v
)) && (0 == SCM_I_ARRAY_BASE (ra
))
591 && SCM_I_ARRAY_DIMS (ra
)->inc
)
595 SCM sra
= scm_i_make_array (1);
596 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
597 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
598 SCM_I_ARRAY_V (sra
) = v
;
599 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
600 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
611 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
613 if (k
== scm_array_handle_rank (handle
))
614 scm_array_handle_set (handle
, pos
, lst
);
617 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
618 ssize_t inc
= dim
->inc
;
619 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
623 while (n
> 0 && scm_is_pair (lst
))
625 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
631 errmsg
= "too few elements for array dimension ~a, need ~a";
632 if (!scm_is_null (lst
))
633 errmsg
= "too many elements for array dimension ~a, want ~a";
635 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
636 scm_from_size_t (len
)));
641 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
642 (SCM type
, SCM shape
, SCM lst
),
643 "Return an array of the type @var{type}\n"
644 "with elements the same as those of @var{lst}.\n"
646 "The argument @var{shape} determines the number of dimensions\n"
647 "of the array and their shape. It is either an exact integer,\n"
649 "number of dimensions directly, or a list whose length\n"
650 "specifies the number of dimensions and each element specified\n"
651 "the lower and optionally the upper bound of the corresponding\n"
653 "When the element is list of two elements, these elements\n"
654 "give the lower and upper bounds. When it is an exact\n"
655 "integer, it gives only the lower bound.")
656 #define FUNC_NAME s_scm_list_to_typed_array
660 scm_t_array_handle handle
;
663 if (scm_is_integer (shape
))
665 size_t k
= scm_to_size_t (shape
);
669 shape
= scm_cons (scm_length (row
), shape
);
670 if (k
> 0 && !scm_is_null (row
))
676 SCM shape_spec
= shape
;
680 SCM spec
= scm_car (shape_spec
);
681 if (scm_is_pair (spec
))
682 shape
= scm_cons (spec
, shape
);
684 shape
= scm_cons (scm_list_2 (spec
,
685 scm_sum (scm_sum (spec
,
689 shape_spec
= scm_cdr (shape_spec
);
690 if (scm_is_pair (shape_spec
))
692 if (!scm_is_null (row
))
700 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
701 scm_reverse_x (shape
, SCM_EOL
));
703 scm_array_get_handle (ra
, &handle
);
704 list_to_array (lst
, &handle
, 0, 0);
705 scm_array_handle_release (&handle
);
711 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
713 "Return an array with elements the same as those of @var{lst}.")
714 #define FUNC_NAME s_scm_list_to_array
716 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
720 /* Print dimension DIM of ARRAY.
724 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
725 SCM port
, scm_print_state
*pstate
)
728 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
732 scm_putc_unlocked ('(', port
);
733 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
734 i
++, pos
+= h
->dims
[dim
].inc
)
736 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
737 if (i
< h
->dims
[dim
].ubnd
)
738 scm_putc_unlocked (' ', port
);
740 scm_putc_unlocked (')', port
);
749 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
751 scm_t_array_handle h
;
753 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
755 scm_array_get_handle (array
, &h
);
757 scm_putc_unlocked ('#', port
);
758 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
759 scm_intprint (h
.ndims
, 10, port
);
760 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
761 scm_write (scm_array_handle_element_type (&h
), port
);
763 for (i
= 0; i
< h
.ndims
; i
++)
765 if (h
.dims
[i
].lbnd
!= 0)
767 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
773 if (print_lbnds
|| print_lens
)
774 for (i
= 0; i
< h
.ndims
; i
++)
778 scm_putc_unlocked ('@', port
);
779 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
783 scm_putc_unlocked (':', port
);
784 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
791 /* Rank zero arrays, which are really just scalars, are printed
792 specially. The consequent way would be to print them as
796 where OBJ is the printed representation of the scalar, but we
797 print them instead as
801 to make them look less strange.
803 Just printing them as
807 would be correct in a way as well, but zero rank arrays are
808 not really the same as Scheme values since they are boxed and
809 can be modified with array-set!, say.
811 scm_putc_unlocked ('(', port
);
812 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
813 scm_putc_unlocked (')', port
);
817 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
823 scm_add_feature ("array");
825 #include "libguile/arrays.x"