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_I_ARRAYP (ra
))
70 return SCM_I_ARRAY_V (ra
);
71 else if (!scm_is_array (ra
))
72 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
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
))
150 s
->ubnd
= scm_to_ssize_t (spec
);
152 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
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_ssize_t (SCM_CAR (spec
));
160 spec
= SCM_CDR (spec
);
161 if (!scm_is_pair (spec
)
162 || !scm_is_integer (SCM_CAR (spec
))
163 || !scm_is_null (SCM_CDR (spec
)))
164 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
165 s
->ubnd
= scm_to_ssize_t (SCM_CAR (spec
));
166 if (s
->ubnd
- s
->lbnd
< -1)
167 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
174 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
175 (SCM type
, SCM fill
, SCM bounds
),
176 "Create and return an array of type @var{type}.")
177 #define FUNC_NAME s_scm_make_typed_array
183 ra
= scm_i_shap2ra (bounds
);
184 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
185 s
= SCM_I_ARRAY_DIMS (ra
);
186 k
= SCM_I_ARRAY_NDIM (ra
);
191 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
192 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
195 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
196 fill
= SCM_UNDEFINED
;
199 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), fill
);
201 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
203 return SCM_I_ARRAY_V (ra
);
210 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
212 #define FUNC_NAME "scm_from_contiguous_typed_array"
217 scm_t_array_handle h
;
221 ra
= scm_i_shap2ra (bounds
);
222 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
223 s
= SCM_I_ARRAY_DIMS (ra
);
224 k
= SCM_I_ARRAY_NDIM (ra
);
229 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
230 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
233 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), SCM_UNDEFINED
);
236 scm_array_get_handle (ra
, &h
);
237 elts
= h
.writable_elements
;
238 sz
= scm_array_handle_uniform_element_bit_size (&h
);
239 scm_array_handle_release (&h
);
241 if (sz
>= 8 && ((sz
% 8) == 0))
243 if (byte_len
% (sz
/ 8))
244 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
245 if (byte_len
/ (sz
/ 8) != rlen
)
246 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
250 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
252 if (byte_len
!= ((rlen
* sz
+ 31) / 32) * 4)
253 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
256 /* an internal guile error, really */
257 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
259 memcpy (elts
, bytes
, byte_len
);
261 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
263 return SCM_I_ARRAY_V (ra
);
269 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
270 #define FUNC_NAME "scm_from_contiguous_array"
275 scm_t_array_handle h
;
277 ra
= scm_i_shap2ra (bounds
);
278 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
279 s
= SCM_I_ARRAY_DIMS (ra
);
280 k
= SCM_I_ARRAY_NDIM (ra
);
285 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
286 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
289 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
291 SCM_I_ARRAY_V (ra
) = scm_c_make_vector (rlen
, SCM_UNDEFINED
);
292 scm_array_get_handle (ra
, &h
);
293 memcpy (h
.writable_elements
, elts
, rlen
* sizeof(SCM
));
294 scm_array_handle_release (&h
);
296 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
298 return SCM_I_ARRAY_V (ra
);
303 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
304 (SCM fill
, SCM bounds
),
305 "Create and return an array.")
306 #define FUNC_NAME s_scm_make_array
308 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
313 scm_i_ra_set_contp (SCM ra
)
315 size_t k
= SCM_I_ARRAY_NDIM (ra
);
318 ssize_t inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
321 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
323 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
326 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
327 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
330 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
334 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
335 (SCM oldra
, SCM mapfunc
, SCM dims
),
336 "@code{make-shared-array} can be used to create shared subarrays\n"
337 "of other arrays. The @var{mapfunc} is a function that\n"
338 "translates coordinates in the new array into coordinates in the\n"
339 "old array. A @var{mapfunc} must be linear, and its range must\n"
340 "stay within the bounds of the old array, but it can be\n"
341 "otherwise arbitrary. A simple example:\n"
343 "(define fred (make-array #f 8 8))\n"
344 "(define freds-diagonal\n"
345 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
346 "(array-set! freds-diagonal 'foo 3)\n"
347 "(array-ref fred 3 3) @result{} foo\n"
348 "(define freds-center\n"
349 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
350 "(array-ref freds-center 0 0) @result{} foo\n"
352 #define FUNC_NAME s_scm_make_shared_array
354 scm_t_array_handle old_handle
;
360 long old_base
, old_min
, new_min
, old_max
, new_max
;
363 SCM_VALIDATE_REST_ARGUMENT (dims
);
364 SCM_VALIDATE_PROC (2, mapfunc
);
365 ra
= scm_i_shap2ra (dims
);
367 scm_array_get_handle (oldra
, &old_handle
);
369 if (SCM_I_ARRAYP (oldra
))
371 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
372 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
373 s
= scm_array_handle_dims (&old_handle
);
374 k
= scm_array_handle_rank (&old_handle
);
378 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
380 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
385 SCM_I_ARRAY_V (ra
) = oldra
;
386 old_base
= old_min
= 0;
387 old_max
= scm_c_array_length (oldra
) - 1;
391 s
= SCM_I_ARRAY_DIMS (ra
);
392 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
394 inds
= scm_cons (scm_from_ssize_t (s
[k
].lbnd
), inds
);
395 if (s
[k
].ubnd
< s
[k
].lbnd
)
397 if (1 == SCM_I_ARRAY_NDIM (ra
))
398 ra
= scm_make_generalized_vector (scm_array_type (ra
),
399 SCM_INUM0
, SCM_UNDEFINED
);
402 scm_make_generalized_vector (scm_array_type (ra
),
403 SCM_INUM0
, SCM_UNDEFINED
);
404 scm_array_handle_release (&old_handle
);
409 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
410 i
= scm_array_handle_pos (&old_handle
, imap
);
411 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
413 k
= SCM_I_ARRAY_NDIM (ra
);
416 if (s
[k
].ubnd
> s
[k
].lbnd
)
418 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
419 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
420 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
423 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
425 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
428 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
429 indptr
= SCM_CDR (indptr
);
432 scm_array_handle_release (&old_handle
);
434 if (old_min
> new_min
|| old_max
< new_max
)
435 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
436 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
438 SCM v
= SCM_I_ARRAY_V (ra
);
439 size_t length
= scm_c_array_length (v
);
440 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
442 if (s
->ubnd
< s
->lbnd
)
443 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
446 scm_i_ra_set_contp (ra
);
452 /* args are RA . DIMS */
453 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
455 "Return an array sharing contents with @var{ra}, but with\n"
456 "dimensions arranged in a different order. There must be one\n"
457 "@var{dim} argument for each dimension of @var{ra}.\n"
458 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
459 "and the rank of the array to be returned. Each integer in that\n"
460 "range must appear at least once in the argument list.\n"
462 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
463 "dimensions in the array to be returned, their positions in the\n"
464 "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
465 "may have the same value, in which case the returned array will\n"
466 "have smaller rank than @var{ra}.\n"
469 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
470 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
471 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
472 " #2((a 4) (b 5) (c 6))\n"
474 #define FUNC_NAME s_scm_transpose_array
477 scm_t_array_dim
*s
, *r
;
480 SCM_VALIDATE_REST_ARGUMENT (args
);
481 SCM_ASSERT (SCM_HEAP_OBJECT_P (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
483 switch (scm_c_array_rank (ra
))
486 if (!scm_is_null (args
))
487 SCM_WRONG_NUM_ARGS ();
490 /* Make sure that we are called with a single zero as
493 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
494 SCM_WRONG_NUM_ARGS ();
495 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
496 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
499 vargs
= scm_vector (args
);
500 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
501 SCM_WRONG_NUM_ARGS ();
503 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
505 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
506 0, SCM_I_ARRAY_NDIM(ra
));
511 res
= scm_i_make_array (ndim
);
512 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
513 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
516 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
517 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
519 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
521 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
522 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
523 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
524 if (r
->ubnd
< r
->lbnd
)
533 if (r
->ubnd
> s
->ubnd
)
535 if (r
->lbnd
< s
->lbnd
)
537 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
544 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
545 scm_i_ra_set_contp (res
);
551 /* attempts to unroll an array into a one-dimensional array.
552 returns the unrolled array or #f if it can't be done. */
553 /* if strict is true, return #f if returned array
554 wouldn't have contiguous elements. */
555 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
556 (SCM ra
, SCM strict
),
557 "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
558 "array without changing their order (last subscript changing\n"
559 "fastest), then @code{array-contents} returns that shared array,\n"
560 "otherwise it returns @code{#f}. All arrays made by\n"
561 "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
562 "some arrays made by @code{make-shared-array} may not be. If\n"
563 "the optional argument @var{strict} is provided, a shared array\n"
564 "will be returned only if its elements are stored internally\n"
565 "contiguous in memory.")
566 #define FUNC_NAME s_scm_array_contents
568 if (!scm_is_array (ra
))
569 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
570 else if (SCM_I_ARRAYP (ra
))
573 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
574 if (!SCM_I_ARRAY_CONTP (ra
))
576 for (k
= 0; k
< ndim
; k
++)
577 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
578 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
580 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
582 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
584 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
585 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
591 v
= SCM_I_ARRAY_V (ra
);
592 if ((len
== scm_c_array_length (v
)) && (0 == SCM_I_ARRAY_BASE (ra
)))
596 SCM sra
= scm_i_make_array (1);
597 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
598 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
599 SCM_I_ARRAY_V (sra
) = v
;
600 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
601 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
612 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
614 if (k
== scm_array_handle_rank (handle
))
615 scm_array_handle_set (handle
, pos
, lst
);
618 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
619 ssize_t inc
= dim
->inc
;
620 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
624 while (n
> 0 && scm_is_pair (lst
))
626 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
632 errmsg
= "too few elements for array dimension ~a, need ~a";
633 if (!scm_is_null (lst
))
634 errmsg
= "too many elements for array dimension ~a, want ~a";
636 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_size_t (k
),
637 scm_from_size_t (len
)));
642 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
643 (SCM type
, SCM shape
, SCM lst
),
644 "Return an array of the type @var{type}\n"
645 "with elements the same as those of @var{lst}.\n"
647 "The argument @var{shape} determines the number of dimensions\n"
648 "of the array and their shape. It is either an exact integer,\n"
650 "number of dimensions directly, or a list whose length\n"
651 "specifies the number of dimensions and each element specified\n"
652 "the lower and optionally the upper bound of the corresponding\n"
654 "When the element is list of two elements, these elements\n"
655 "give the lower and upper bounds. When it is an exact\n"
656 "integer, it gives only the lower bound.")
657 #define FUNC_NAME s_scm_list_to_typed_array
661 scm_t_array_handle handle
;
664 if (scm_is_integer (shape
))
666 size_t k
= scm_to_size_t (shape
);
670 shape
= scm_cons (scm_length (row
), shape
);
671 if (k
> 0 && !scm_is_null (row
))
677 SCM shape_spec
= shape
;
681 SCM spec
= scm_car (shape_spec
);
682 if (scm_is_pair (spec
))
683 shape
= scm_cons (spec
, shape
);
685 shape
= scm_cons (scm_list_2 (spec
,
686 scm_sum (scm_sum (spec
,
690 shape_spec
= scm_cdr (shape_spec
);
691 if (scm_is_pair (shape_spec
))
693 if (!scm_is_null (row
))
701 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
702 scm_reverse_x (shape
, SCM_EOL
));
704 scm_array_get_handle (ra
, &handle
);
705 list_to_array (lst
, &handle
, 0, 0);
706 scm_array_handle_release (&handle
);
712 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
714 "Return an array with elements the same as those of @var{lst}.")
715 #define FUNC_NAME s_scm_list_to_array
717 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
721 /* Print dimension DIM of ARRAY.
725 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
726 SCM port
, scm_print_state
*pstate
)
729 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
733 scm_putc_unlocked ('(', port
);
734 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
735 i
++, pos
+= h
->dims
[dim
].inc
)
737 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
738 if (i
< h
->dims
[dim
].ubnd
)
739 scm_putc_unlocked (' ', port
);
741 scm_putc_unlocked (')', port
);
750 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
752 scm_t_array_handle h
;
754 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
756 scm_array_get_handle (array
, &h
);
758 scm_putc_unlocked ('#', port
);
759 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
760 scm_intprint (h
.ndims
, 10, port
);
761 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
762 scm_write (scm_array_handle_element_type (&h
), port
);
764 for (i
= 0; i
< h
.ndims
; i
++)
766 if (h
.dims
[i
].lbnd
!= 0)
768 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
774 if (print_lbnds
|| print_lens
)
775 for (i
= 0; i
< h
.ndims
; i
++)
779 scm_putc_unlocked ('@', port
);
780 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
784 scm_putc_unlocked (':', port
);
785 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
792 /* Rank zero arrays, which are really just scalars, are printed
793 specially. The consequent way would be to print them as
797 where OBJ is the printed representation of the scalar, but we
798 print them instead as
802 to make them look less strange.
804 Just printing them as
808 would be correct in a way as well, but zero rank arrays are
809 not really the same as Scheme values since they are boxed and
810 can be modified with array-set!, say.
812 scm_putc_unlocked ('(', port
);
813 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
814 scm_putc_unlocked (')', port
);
818 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
824 scm_add_feature ("array");
826 #include "libguile/arrays.x"