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
31 #include "libguile/_scm.h"
32 #include "libguile/__scm.h"
33 #include "libguile/eq.h"
34 #include "libguile/chars.h"
35 #include "libguile/eval.h"
36 #include "libguile/fports.h"
37 #include "libguile/feature.h"
38 #include "libguile/root.h"
39 #include "libguile/strings.h"
40 #include "libguile/srfi-13.h"
41 #include "libguile/srfi-4.h"
42 #include "libguile/vectors.h"
43 #include "libguile/bitvectors.h"
44 #include "libguile/bytevectors.h"
45 #include "libguile/list.h"
46 #include "libguile/dynwind.h"
47 #include "libguile/read.h"
49 #include "libguile/validate.h"
50 #include "libguile/arrays.h"
51 #include "libguile/array-map.h"
52 #include "libguile/generalized-vectors.h"
53 #include "libguile/generalized-arrays.h"
54 #include "libguile/uniform.h"
57 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
58 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
59 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
60 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
63 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
65 "Return the root vector of a shared array.")
66 #define FUNC_NAME s_scm_shared_array_root
68 if (!scm_is_array (ra
))
69 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
70 else if (SCM_I_ARRAYP (ra
))
71 return SCM_I_ARRAY_V (ra
);
78 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
80 "Return the root vector index of the first element in the array.")
81 #define FUNC_NAME s_scm_shared_array_offset
83 scm_t_array_handle handle
;
86 scm_array_get_handle (ra
, &handle
);
87 res
= scm_from_size_t (handle
.base
);
88 scm_array_handle_release (&handle
);
94 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
96 "For each dimension, return the distance between elements in the root vector.")
97 #define FUNC_NAME s_scm_shared_array_increments
99 scm_t_array_handle handle
;
104 scm_array_get_handle (ra
, &handle
);
105 k
= scm_array_handle_rank (&handle
);
106 s
= scm_array_handle_dims (&handle
);
108 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
109 scm_array_handle_release (&handle
);
115 scm_i_make_array (int ndim
)
118 ra
= scm_cell (((scm_t_bits
) ndim
<< 17) + scm_tc7_array
,
119 (scm_t_bits
) scm_gc_malloc (sizeof (scm_i_t_array
) +
120 ndim
* sizeof (scm_t_array_dim
),
122 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
126 static char s_bad_spec
[] = "Bad scm_array dimension";
129 /* Increments will still need to be set. */
132 scm_i_shap2ra (SCM args
)
136 int ndim
= scm_ilength (args
);
138 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
140 ra
= scm_i_make_array (ndim
);
141 SCM_I_ARRAY_BASE (ra
) = 0;
142 s
= SCM_I_ARRAY_DIMS (ra
);
143 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
145 spec
= SCM_CAR (args
);
146 if (scm_is_integer (spec
))
148 if (scm_to_long (spec
) < 0)
149 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
151 s
->ubnd
= scm_to_long (spec
) - 1;
156 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
157 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
158 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
160 if (!scm_is_pair (sp
)
161 || !scm_is_integer (SCM_CAR (sp
))
162 || !scm_is_null (SCM_CDR (sp
)))
163 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
164 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
171 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
172 (SCM type
, SCM fill
, SCM bounds
),
173 "Create and return an array of type @var{type}.")
174 #define FUNC_NAME s_scm_make_typed_array
180 ra
= scm_i_shap2ra (bounds
);
181 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
182 s
= SCM_I_ARRAY_DIMS (ra
);
183 k
= SCM_I_ARRAY_NDIM (ra
);
188 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
189 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
192 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
193 fill
= SCM_UNDEFINED
;
196 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), fill
);
198 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
200 return SCM_I_ARRAY_V (ra
);
207 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
209 #define FUNC_NAME "scm_from_contiguous_typed_array"
214 scm_t_array_handle h
;
218 ra
= scm_i_shap2ra (bounds
);
219 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
220 s
= SCM_I_ARRAY_DIMS (ra
);
221 k
= SCM_I_ARRAY_NDIM (ra
);
226 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
227 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
230 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), SCM_UNDEFINED
);
233 scm_array_get_handle (ra
, &h
);
234 elts
= h
.writable_elements
;
235 sz
= scm_array_handle_uniform_element_bit_size (&h
);
236 scm_array_handle_release (&h
);
238 if (sz
>= 8 && ((sz
% 8) == 0))
240 if (byte_len
% (sz
/ 8))
241 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
242 if (byte_len
/ (sz
/ 8) != rlen
)
243 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
247 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
249 if (byte_len
!= ((rlen
* sz
+ 31) / 32) * 4)
250 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
253 /* an internal guile error, really */
254 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
256 memcpy (elts
, bytes
, byte_len
);
258 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
260 return SCM_I_ARRAY_V (ra
);
266 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
267 #define FUNC_NAME "scm_from_contiguous_array"
272 scm_t_array_handle h
;
274 ra
= scm_i_shap2ra (bounds
);
275 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
276 s
= SCM_I_ARRAY_DIMS (ra
);
277 k
= SCM_I_ARRAY_NDIM (ra
);
282 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
283 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
286 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
288 SCM_I_ARRAY_V (ra
) = scm_c_make_vector (rlen
, SCM_UNDEFINED
);
289 scm_array_get_handle (ra
, &h
);
290 memcpy (h
.writable_elements
, elts
, rlen
* sizeof(SCM
));
291 scm_array_handle_release (&h
);
293 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
295 return SCM_I_ARRAY_V (ra
);
300 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
301 (SCM fill
, SCM bounds
),
302 "Create and return an array.")
303 #define FUNC_NAME s_scm_make_array
305 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
310 scm_i_ra_set_contp (SCM ra
)
312 size_t k
= SCM_I_ARRAY_NDIM (ra
);
315 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
318 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
320 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
323 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
324 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
327 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
331 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
332 (SCM oldra
, SCM mapfunc
, SCM dims
),
333 "@code{make-shared-array} can be used to create shared subarrays\n"
334 "of other arrays. The @var{mapfunc} is a function that\n"
335 "translates coordinates in the new array into coordinates in the\n"
336 "old array. A @var{mapfunc} must be linear, and its range must\n"
337 "stay within the bounds of the old array, but it can be\n"
338 "otherwise arbitrary. A simple example:\n"
340 "(define fred (make-array #f 8 8))\n"
341 "(define freds-diagonal\n"
342 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
343 "(array-set! freds-diagonal 'foo 3)\n"
344 "(array-ref fred 3 3) @result{} foo\n"
345 "(define freds-center\n"
346 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
347 "(array-ref freds-center 0 0) @result{} foo\n"
349 #define FUNC_NAME s_scm_make_shared_array
351 scm_t_array_handle old_handle
;
357 long old_base
, old_min
, new_min
, old_max
, new_max
;
360 SCM_VALIDATE_REST_ARGUMENT (dims
);
361 SCM_VALIDATE_PROC (2, mapfunc
);
362 ra
= scm_i_shap2ra (dims
);
364 scm_array_get_handle (oldra
, &old_handle
);
366 if (SCM_I_ARRAYP (oldra
))
368 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
369 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
370 s
= scm_array_handle_dims (&old_handle
);
371 k
= scm_array_handle_rank (&old_handle
);
375 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
377 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
382 SCM_I_ARRAY_V (ra
) = oldra
;
383 old_base
= old_min
= 0;
384 old_max
= scm_c_array_length (oldra
) - 1;
388 s
= SCM_I_ARRAY_DIMS (ra
);
389 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
391 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
392 if (s
[k
].ubnd
< s
[k
].lbnd
)
394 if (1 == SCM_I_ARRAY_NDIM (ra
))
395 ra
= scm_make_generalized_vector (scm_array_type (ra
),
396 SCM_INUM0
, SCM_UNDEFINED
);
399 scm_make_generalized_vector (scm_array_type (ra
),
400 SCM_INUM0
, SCM_UNDEFINED
);
401 scm_array_handle_release (&old_handle
);
406 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
407 i
= scm_array_handle_pos (&old_handle
, imap
);
408 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
410 k
= SCM_I_ARRAY_NDIM (ra
);
413 if (s
[k
].ubnd
> s
[k
].lbnd
)
415 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
416 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
417 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
420 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
422 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
425 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
426 indptr
= SCM_CDR (indptr
);
429 scm_array_handle_release (&old_handle
);
431 if (old_min
> new_min
|| old_max
< new_max
)
432 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
433 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
435 SCM v
= SCM_I_ARRAY_V (ra
);
436 size_t length
= scm_c_array_length (v
);
437 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
439 if (s
->ubnd
< s
->lbnd
)
440 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
443 scm_i_ra_set_contp (ra
);
449 /* args are RA . DIMS */
450 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
452 "Return an array sharing contents with @var{ra}, but with\n"
453 "dimensions arranged in a different order. There must be one\n"
454 "@var{dim} argument for each dimension of @var{ra}.\n"
455 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
456 "and the rank of the array to be returned. Each integer in that\n"
457 "range must appear at least once in the argument list.\n"
459 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
460 "dimensions in the array to be returned, their positions in the\n"
461 "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
462 "may have the same value, in which case the returned array will\n"
463 "have smaller rank than @var{ra}.\n"
466 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
467 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
468 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
469 " #2((a 4) (b 5) (c 6))\n"
471 #define FUNC_NAME s_scm_transpose_array
474 scm_t_array_dim
*s
, *r
;
477 SCM_VALIDATE_REST_ARGUMENT (args
);
478 SCM_ASSERT (SCM_HEAP_OBJECT_P (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
480 switch (scm_c_array_rank (ra
))
483 if (!scm_is_null (args
))
484 SCM_WRONG_NUM_ARGS ();
487 /* Make sure that we are called with a single zero as
490 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
491 SCM_WRONG_NUM_ARGS ();
492 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
493 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
496 vargs
= scm_vector (args
);
497 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
498 SCM_WRONG_NUM_ARGS ();
500 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
502 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
503 0, SCM_I_ARRAY_NDIM(ra
));
508 res
= scm_i_make_array (ndim
);
509 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
510 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
513 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
514 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
516 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
518 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
519 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
520 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
521 if (r
->ubnd
< r
->lbnd
)
530 if (r
->ubnd
> s
->ubnd
)
532 if (r
->lbnd
< s
->lbnd
)
534 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
541 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
542 scm_i_ra_set_contp (res
);
548 /* attempts to unroll an array into a one-dimensional array.
549 returns the unrolled array or #f if it can't be done. */
550 /* if strict is not SCM_UNDEFINED, return #f if returned array
551 wouldn't have contiguous elements. */
552 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
553 (SCM ra
, SCM strict
),
554 "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
555 "array without changing their order (last subscript changing\n"
556 "fastest), then @code{array-contents} returns that shared array,\n"
557 "otherwise it returns @code{#f}. All arrays made by\n"
558 "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
559 "some arrays made by @code{make-shared-array} may not be. If\n"
560 "the optional argument @var{strict} is provided, a shared array\n"
561 "will be returned only if its elements are stored internally\n"
562 "contiguous in memory.")
563 #define FUNC_NAME s_scm_array_contents
567 if (scm_is_generalized_vector (ra
))
570 if (SCM_I_ARRAYP (ra
))
572 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
573 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
575 for (k
= 0; k
< ndim
; k
++)
576 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
577 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
579 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
581 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
583 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
584 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
591 SCM v
= SCM_I_ARRAY_V (ra
);
592 size_t length
= scm_c_array_length (v
);
593 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
597 sra
= scm_i_make_array (1);
598 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
599 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
600 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
601 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
602 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
606 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
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_ulong (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
);
822 array_handle_ref (scm_t_array_handle
*hh
, size_t pos
)
824 return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh
->array
), pos
);
828 array_handle_set (scm_t_array_handle
*hh
, size_t pos
, SCM val
)
830 scm_c_array_set_1_x (SCM_I_ARRAY_V (hh
->array
), val
, pos
);
833 /* FIXME: should be handle for vect? maybe not, because of dims */
835 array_get_handle (SCM array
, scm_t_array_handle
*h
)
837 scm_t_array_handle vh
;
838 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
839 h
->element_type
= vh
.element_type
;
840 h
->elements
= vh
.elements
;
841 h
->writable_elements
= vh
.writable_elements
;
842 scm_array_handle_release (&vh
);
844 h
->dims
= SCM_I_ARRAY_DIMS (array
);
845 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
846 h
->base
= SCM_I_ARRAY_BASE (array
);
849 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array
,
851 array_handle_ref
, array_handle_set
,
857 scm_add_feature ("array");
859 #include "libguile/arrays.x"