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_I_ARRAYP (ra
))
69 return SCM_I_ARRAY_V (ra
);
70 else if (scm_is_generalized_vector (ra
))
72 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
77 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
79 "Return the root vector index of the first element in the array.")
80 #define FUNC_NAME s_scm_shared_array_offset
82 scm_t_array_handle handle
;
85 scm_array_get_handle (ra
, &handle
);
86 res
= scm_from_size_t (handle
.base
);
87 scm_array_handle_release (&handle
);
93 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
95 "For each dimension, return the distance between elements in the root vector.")
96 #define FUNC_NAME s_scm_shared_array_increments
98 scm_t_array_handle handle
;
103 scm_array_get_handle (ra
, &handle
);
104 k
= scm_array_handle_rank (&handle
);
105 s
= scm_array_handle_dims (&handle
);
107 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
108 scm_array_handle_release (&handle
);
114 scm_i_make_array (int ndim
)
117 ra
= scm_cell (((scm_t_bits
) ndim
<< 17) + scm_tc7_array
,
118 (scm_t_bits
) scm_gc_malloc (sizeof (scm_i_t_array
) +
119 ndim
* sizeof (scm_t_array_dim
),
121 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
125 static char s_bad_spec
[] = "Bad scm_array dimension";
128 /* Increments will still need to be set. */
131 scm_i_shap2ra (SCM args
)
135 int ndim
= scm_ilength (args
);
137 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
139 ra
= scm_i_make_array (ndim
);
140 SCM_I_ARRAY_BASE (ra
) = 0;
141 s
= SCM_I_ARRAY_DIMS (ra
);
142 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
144 spec
= SCM_CAR (args
);
145 if (scm_is_integer (spec
))
147 if (scm_to_long (spec
) < 0)
148 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
150 s
->ubnd
= scm_to_long (spec
) - 1;
155 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
156 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
157 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
159 if (!scm_is_pair (sp
)
160 || !scm_is_integer (SCM_CAR (sp
))
161 || !scm_is_null (SCM_CDR (sp
)))
162 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
163 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
170 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
171 (SCM type
, SCM fill
, SCM bounds
),
172 "Create and return an array of type @var{type}.")
173 #define FUNC_NAME s_scm_make_typed_array
179 ra
= scm_i_shap2ra (bounds
);
180 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
181 s
= SCM_I_ARRAY_DIMS (ra
);
182 k
= SCM_I_ARRAY_NDIM (ra
);
187 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
188 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
191 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
192 fill
= SCM_UNDEFINED
;
195 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), fill
);
197 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
199 return SCM_I_ARRAY_V (ra
);
206 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
208 #define FUNC_NAME "scm_from_contiguous_typed_array"
213 scm_t_array_handle h
;
217 ra
= scm_i_shap2ra (bounds
);
218 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
219 s
= SCM_I_ARRAY_DIMS (ra
);
220 k
= SCM_I_ARRAY_NDIM (ra
);
225 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
226 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
229 scm_make_generalized_vector (type
, scm_from_size_t (rlen
), SCM_UNDEFINED
);
232 scm_array_get_handle (ra
, &h
);
233 elts
= h
.writable_elements
;
234 sz
= scm_array_handle_uniform_element_bit_size (&h
);
235 scm_array_handle_release (&h
);
237 if (sz
>= 8 && ((sz
% 8) == 0))
239 if (byte_len
% (sz
/ 8))
240 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
241 if (byte_len
/ (sz
/ 8) != rlen
)
242 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
246 /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
248 if (byte_len
!= ((rlen
* sz
+ 31) / 32) * 4)
249 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
252 /* an internal guile error, really */
253 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
255 memcpy (elts
, bytes
, byte_len
);
257 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
259 return SCM_I_ARRAY_V (ra
);
265 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
266 #define FUNC_NAME "scm_from_contiguous_array"
271 scm_t_array_handle h
;
273 ra
= scm_i_shap2ra (bounds
);
274 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
275 s
= SCM_I_ARRAY_DIMS (ra
);
276 k
= SCM_I_ARRAY_NDIM (ra
);
281 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
282 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
285 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
287 SCM_I_ARRAY_V (ra
) = scm_c_make_vector (rlen
, SCM_UNDEFINED
);
288 scm_array_get_handle (ra
, &h
);
289 memcpy (h
.writable_elements
, elts
, rlen
* sizeof(SCM
));
290 scm_array_handle_release (&h
);
292 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
294 return SCM_I_ARRAY_V (ra
);
299 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
300 (SCM fill
, SCM bounds
),
301 "Create and return an array.")
302 #define FUNC_NAME s_scm_make_array
304 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
309 scm_i_ra_set_contp (SCM ra
)
311 size_t k
= SCM_I_ARRAY_NDIM (ra
);
314 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
317 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
319 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
322 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
323 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
326 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
330 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
331 (SCM oldra
, SCM mapfunc
, SCM dims
),
332 "@code{make-shared-array} can be used to create shared subarrays\n"
333 "of other arrays. The @var{mapfunc} is a function that\n"
334 "translates coordinates in the new array into coordinates in the\n"
335 "old array. A @var{mapfunc} must be linear, and its range must\n"
336 "stay within the bounds of the old array, but it can be\n"
337 "otherwise arbitrary. A simple example:\n"
339 "(define fred (make-array #f 8 8))\n"
340 "(define freds-diagonal\n"
341 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
342 "(array-set! freds-diagonal 'foo 3)\n"
343 "(array-ref fred 3 3) @result{} foo\n"
344 "(define freds-center\n"
345 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
346 "(array-ref freds-center 0 0) @result{} foo\n"
348 #define FUNC_NAME s_scm_make_shared_array
350 scm_t_array_handle old_handle
;
356 long old_base
, old_min
, new_min
, old_max
, new_max
;
359 SCM_VALIDATE_REST_ARGUMENT (dims
);
360 SCM_VALIDATE_PROC (2, mapfunc
);
361 ra
= scm_i_shap2ra (dims
);
363 scm_array_get_handle (oldra
, &old_handle
);
365 if (SCM_I_ARRAYP (oldra
))
367 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
368 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
369 s
= scm_array_handle_dims (&old_handle
);
370 k
= scm_array_handle_rank (&old_handle
);
374 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
376 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
381 SCM_I_ARRAY_V (ra
) = oldra
;
382 old_base
= old_min
= 0;
383 old_max
= scm_c_array_length (oldra
) - 1;
387 s
= SCM_I_ARRAY_DIMS (ra
);
388 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
390 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
391 if (s
[k
].ubnd
< s
[k
].lbnd
)
393 if (1 == SCM_I_ARRAY_NDIM (ra
))
394 ra
= scm_make_generalized_vector (scm_array_type (ra
),
395 SCM_INUM0
, SCM_UNDEFINED
);
398 scm_make_generalized_vector (scm_array_type (ra
),
399 SCM_INUM0
, SCM_UNDEFINED
);
400 scm_array_handle_release (&old_handle
);
405 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
406 i
= scm_array_handle_pos (&old_handle
, imap
);
407 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
409 k
= SCM_I_ARRAY_NDIM (ra
);
412 if (s
[k
].ubnd
> s
[k
].lbnd
)
414 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
415 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
416 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
419 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
421 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
424 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
425 indptr
= SCM_CDR (indptr
);
428 scm_array_handle_release (&old_handle
);
430 if (old_min
> new_min
|| old_max
< new_max
)
431 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
432 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
434 SCM v
= SCM_I_ARRAY_V (ra
);
435 size_t length
= scm_c_array_length (v
);
436 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
438 if (s
->ubnd
< s
->lbnd
)
439 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
442 scm_i_ra_set_contp (ra
);
448 /* args are RA . DIMS */
449 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
451 "Return an array sharing contents with @var{ra}, but with\n"
452 "dimensions arranged in a different order. There must be one\n"
453 "@var{dim} argument for each dimension of @var{ra}.\n"
454 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
455 "and the rank of the array to be returned. Each integer in that\n"
456 "range must appear at least once in the argument list.\n"
458 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
459 "dimensions in the array to be returned, their positions in the\n"
460 "argument list to dimensions of @var{ra}. Several @var{dim}s\n"
461 "may have the same value, in which case the returned array will\n"
462 "have smaller rank than @var{ra}.\n"
465 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
466 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
467 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
468 " #2((a 4) (b 5) (c 6))\n"
470 #define FUNC_NAME s_scm_transpose_array
473 scm_t_array_dim
*s
, *r
;
476 SCM_VALIDATE_REST_ARGUMENT (args
);
477 SCM_ASSERT (SCM_HEAP_OBJECT_P (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
479 if (scm_is_generalized_vector (ra
))
481 /* Make sure that we are called with a single zero as
484 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
485 SCM_WRONG_NUM_ARGS ();
486 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
487 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
491 if (SCM_I_ARRAYP (ra
))
493 vargs
= scm_vector (args
);
494 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
495 SCM_WRONG_NUM_ARGS ();
497 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
499 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
500 0, SCM_I_ARRAY_NDIM(ra
));
505 res
= scm_i_make_array (ndim
);
506 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
507 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
510 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
511 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
513 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
515 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
516 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
517 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
518 if (r
->ubnd
< r
->lbnd
)
527 if (r
->ubnd
> s
->ubnd
)
529 if (r
->lbnd
< s
->lbnd
)
531 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
538 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
539 scm_i_ra_set_contp (res
);
543 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
547 /* attempts to unroll an array into a one-dimensional array.
548 returns the unrolled array or #f if it can't be done. */
549 /* if strict is not SCM_UNDEFINED, return #f if returned array
550 wouldn't have contiguous elements. */
551 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
552 (SCM ra
, SCM strict
),
553 "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
554 "array without changing their order (last subscript changing\n"
555 "fastest), then @code{array-contents} returns that shared array,\n"
556 "otherwise it returns @code{#f}. All arrays made by\n"
557 "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
558 "some arrays made by @code{make-shared-array} may not be. If\n"
559 "the optional argument @var{strict} is provided, a shared array\n"
560 "will be returned only if its elements are stored internally\n"
561 "contiguous in memory.")
562 #define FUNC_NAME s_scm_array_contents
566 if (scm_is_generalized_vector (ra
))
569 if (SCM_I_ARRAYP (ra
))
571 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
572 if (!SCM_I_ARRAYP (ra
) || !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
||
590 SCM v
= SCM_I_ARRAY_V (ra
);
591 size_t length
= scm_c_array_length (v
);
592 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
596 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
) = SCM_I_ARRAY_V (ra
);
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);
605 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
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
);
821 array_handle_ref (scm_t_array_handle
*hh
, size_t pos
)
823 return scm_c_array_ref_1 (SCM_I_ARRAY_V (hh
->array
), pos
);
827 array_handle_set (scm_t_array_handle
*hh
, size_t pos
, SCM val
)
829 scm_c_array_set_1_x (SCM_I_ARRAY_V (hh
->array
), val
, pos
);
832 /* FIXME: should be handle for vect? maybe not, because of dims */
834 array_get_handle (SCM array
, scm_t_array_handle
*h
)
836 scm_t_array_handle vh
;
837 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
838 h
->element_type
= vh
.element_type
;
839 h
->elements
= vh
.elements
;
840 h
->writable_elements
= vh
.writable_elements
;
841 scm_array_handle_release (&vh
);
843 h
->dims
= SCM_I_ARRAY_DIMS (array
);
844 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
845 h
->base
= SCM_I_ARRAY_BASE (array
);
848 SCM_ARRAY_IMPLEMENTATION (scm_tc7_array
,
850 array_handle_ref
, array_handle_set
,
856 scm_add_feature ("array");
858 #include "libguile/arrays.x"