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
568 if (scm_is_generalized_vector (ra
))
571 if (SCM_I_ARRAYP (ra
))
573 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
574 if (!SCM_I_ARRAYP (ra
) || !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
||
592 SCM v
= SCM_I_ARRAY_V (ra
);
593 size_t length
= scm_c_array_length (v
);
594 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
598 sra
= scm_i_make_array (1);
599 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
600 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
601 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
602 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
603 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
607 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
613 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
615 if (k
== scm_array_handle_rank (handle
))
616 scm_array_handle_set (handle
, pos
, lst
);
619 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
620 ssize_t inc
= dim
->inc
;
621 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
625 while (n
> 0 && scm_is_pair (lst
))
627 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
633 errmsg
= "too few elements for array dimension ~a, need ~a";
634 if (!scm_is_null (lst
))
635 errmsg
= "too many elements for array dimension ~a, want ~a";
637 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
638 scm_from_size_t (len
)));
643 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
644 (SCM type
, SCM shape
, SCM lst
),
645 "Return an array of the type @var{type}\n"
646 "with elements the same as those of @var{lst}.\n"
648 "The argument @var{shape} determines the number of dimensions\n"
649 "of the array and their shape. It is either an exact integer,\n"
651 "number of dimensions directly, or a list whose length\n"
652 "specifies the number of dimensions and each element specified\n"
653 "the lower and optionally the upper bound of the corresponding\n"
655 "When the element is list of two elements, these elements\n"
656 "give the lower and upper bounds. When it is an exact\n"
657 "integer, it gives only the lower bound.")
658 #define FUNC_NAME s_scm_list_to_typed_array
662 scm_t_array_handle handle
;
665 if (scm_is_integer (shape
))
667 size_t k
= scm_to_size_t (shape
);
671 shape
= scm_cons (scm_length (row
), shape
);
672 if (k
> 0 && !scm_is_null (row
))
678 SCM shape_spec
= shape
;
682 SCM spec
= scm_car (shape_spec
);
683 if (scm_is_pair (spec
))
684 shape
= scm_cons (spec
, shape
);
686 shape
= scm_cons (scm_list_2 (spec
,
687 scm_sum (scm_sum (spec
,
691 shape_spec
= scm_cdr (shape_spec
);
692 if (scm_is_pair (shape_spec
))
694 if (!scm_is_null (row
))
702 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
703 scm_reverse_x (shape
, SCM_EOL
));
705 scm_array_get_handle (ra
, &handle
);
706 list_to_array (lst
, &handle
, 0, 0);
707 scm_array_handle_release (&handle
);
713 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
715 "Return an array with elements the same as those of @var{lst}.")
716 #define FUNC_NAME s_scm_list_to_array
718 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
722 /* Print dimension DIM of ARRAY.
726 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
727 SCM port
, scm_print_state
*pstate
)
730 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
734 scm_putc_unlocked ('(', port
);
735 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
736 i
++, pos
+= h
->dims
[dim
].inc
)
738 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
739 if (i
< h
->dims
[dim
].ubnd
)
740 scm_putc_unlocked (' ', port
);
742 scm_putc_unlocked (')', port
);
751 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
753 scm_t_array_handle h
;
755 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
757 scm_array_get_handle (array
, &h
);
759 scm_putc_unlocked ('#', port
);
760 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
761 scm_intprint (h
.ndims
, 10, port
);
762 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
763 scm_write (scm_array_handle_element_type (&h
), port
);
765 for (i
= 0; i
< h
.ndims
; i
++)
767 if (h
.dims
[i
].lbnd
!= 0)
769 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
775 if (print_lbnds
|| print_lens
)
776 for (i
= 0; i
< h
.ndims
; i
++)
780 scm_putc_unlocked ('@', port
);
781 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
785 scm_putc_unlocked (':', port
);
786 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
793 /* Rank zero arrays, which are really just scalars, are printed
794 specially. The consequent way would be to print them as
798 where OBJ is the printed representation of the scalar, but we
799 print them instead as
803 to make them look less strange.
805 Just printing them as
809 would be correct in a way as well, but zero rank arrays are
810 not really the same as Scheme values since they are boxed and
811 can be modified with array-set!, say.
813 scm_putc_unlocked ('(', port
);
814 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
815 scm_putc_unlocked (')', port
);
819 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
823 array_handle_ref (scm_t_array_handle
*hh
, size_t pos
)
825 return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh
->array
), pos
);
829 array_handle_set (scm_t_array_handle
*hh
, size_t pos
, SCM val
)
831 scm_c_array_set_1_x (SCM_I_ARRAY_V (hh
->array
), val
, pos
);
834 /* FIXME: should be handle for vect? maybe not, because of dims */
836 array_get_handle (SCM array
, scm_t_array_handle
*h
)
838 scm_t_array_handle vh
;
839 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
840 assert (vh
.dims
[0].inc
== 1 && vh
.dims
[0].lbnd
== 0 && vh
.base
== 0);
841 h
->element_type
= vh
.element_type
;
842 h
->elements
= vh
.elements
;
843 h
->writable_elements
= vh
.writable_elements
;
844 scm_array_handle_release (&vh
);
846 h
->dims
= SCM_I_ARRAY_DIMS (array
);
847 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
848 h
->base
= SCM_I_ARRAY_BASE (array
);
851 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array
,
853 array_handle_ref
, array_handle_set
,
859 scm_add_feature ("array");
861 #include "libguile/arrays.x"