1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/__scm.h"
32 #include "libguile/eq.h"
33 #include "libguile/chars.h"
34 #include "libguile/eval.h"
35 #include "libguile/fports.h"
36 #include "libguile/smob.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 scm_t_bits scm_i_tc16_array
;
58 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
59 (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
60 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
61 (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
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_generalized_vector (ra
))
73 scm_wrong_type_arg_msg (FUNC_NAME
, SCM_ARG1
, ra
, "array");
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 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_i_tc16_array
,
119 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
))
199 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
200 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 /* byte_len ?= ceil (rlen * sz / 8) */
247 if (byte_len
!= (rlen
* sz
+ 7) / 8)
248 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
251 /* an internal guile error, really */
252 SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL
);
254 memcpy (elts
, bytes
, byte_len
);
256 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
257 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
258 return SCM_I_ARRAY_V (ra
);
264 scm_from_contiguous_array (SCM bounds
, const SCM
*elts
, size_t len
)
265 #define FUNC_NAME "scm_from_contiguous_array"
270 scm_t_array_handle h
;
272 ra
= scm_i_shap2ra (bounds
);
273 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
274 s
= SCM_I_ARRAY_DIMS (ra
);
275 k
= SCM_I_ARRAY_NDIM (ra
);
280 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
281 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
284 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL
);
286 SCM_I_ARRAY_V (ra
) = scm_c_make_vector (rlen
, SCM_UNDEFINED
);
287 scm_array_get_handle (ra
, &h
);
288 memcpy (h
.writable_elements
, elts
, rlen
* sizeof(SCM
));
289 scm_array_handle_release (&h
);
291 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
292 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
293 return SCM_I_ARRAY_V (ra
);
298 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
299 (SCM fill
, SCM bounds
),
300 "Create and return an array.")
301 #define FUNC_NAME s_scm_make_array
303 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
308 scm_i_ra_set_contp (SCM ra
)
310 size_t k
= SCM_I_ARRAY_NDIM (ra
);
313 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
316 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
318 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
321 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
322 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
325 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
329 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
330 (SCM oldra
, SCM mapfunc
, SCM dims
),
331 "@code{make-shared-array} can be used to create shared subarrays of other\n"
332 "arrays. The @var{mapper} is a function that translates coordinates in\n"
333 "the new array into coordinates in the old array. A @var{mapper} must be\n"
334 "linear, and its range must stay within the bounds of the old array, but\n"
335 "it can be otherwise arbitrary. A simple example:\n"
337 "(define fred (make-array #f 8 8))\n"
338 "(define freds-diagonal\n"
339 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
340 "(array-set! freds-diagonal 'foo 3)\n"
341 "(array-ref fred 3 3) @result{} foo\n"
342 "(define freds-center\n"
343 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
344 "(array-ref freds-center 0 0) @result{} foo\n"
346 #define FUNC_NAME s_scm_make_shared_array
348 scm_t_array_handle old_handle
;
354 long old_base
, old_min
, new_min
, old_max
, new_max
;
357 SCM_VALIDATE_REST_ARGUMENT (dims
);
358 SCM_VALIDATE_PROC (2, mapfunc
);
359 ra
= scm_i_shap2ra (dims
);
361 scm_array_get_handle (oldra
, &old_handle
);
363 if (SCM_I_ARRAYP (oldra
))
365 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
366 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
367 s
= scm_array_handle_dims (&old_handle
);
368 k
= scm_array_handle_rank (&old_handle
);
372 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
374 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
379 SCM_I_ARRAY_V (ra
) = oldra
;
380 old_base
= old_min
= 0;
381 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
385 s
= SCM_I_ARRAY_DIMS (ra
);
386 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
388 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
389 if (s
[k
].ubnd
< s
[k
].lbnd
)
391 if (1 == SCM_I_ARRAY_NDIM (ra
))
392 ra
= scm_make_generalized_vector (scm_array_type (ra
),
393 SCM_INUM0
, SCM_UNDEFINED
);
396 scm_make_generalized_vector (scm_array_type (ra
),
397 SCM_INUM0
, SCM_UNDEFINED
);
398 scm_array_handle_release (&old_handle
);
403 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
404 i
= scm_array_handle_pos (&old_handle
, imap
);
405 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
407 k
= SCM_I_ARRAY_NDIM (ra
);
410 if (s
[k
].ubnd
> s
[k
].lbnd
)
412 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
413 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
414 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
417 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
419 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
422 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
423 indptr
= SCM_CDR (indptr
);
426 scm_array_handle_release (&old_handle
);
428 if (old_min
> new_min
|| old_max
< new_max
)
429 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
430 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
432 SCM v
= SCM_I_ARRAY_V (ra
);
433 size_t length
= scm_c_generalized_vector_length (v
);
434 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
436 if (s
->ubnd
< s
->lbnd
)
437 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
440 scm_i_ra_set_contp (ra
);
446 /* args are RA . DIMS */
447 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
449 "Return an array sharing contents with @var{array}, but with\n"
450 "dimensions arranged in a different order. There must be one\n"
451 "@var{dim} argument for each dimension of @var{array}.\n"
452 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
453 "and the rank of the array to be returned. Each integer in that\n"
454 "range must appear at least once in the argument list.\n"
456 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
457 "dimensions in the array to be returned, their positions in the\n"
458 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
459 "may have the same value, in which case the returned array will\n"
460 "have smaller rank than @var{array}.\n"
463 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
464 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
465 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
466 " #2((a 4) (b 5) (c 6))\n"
468 #define FUNC_NAME s_scm_transpose_array
471 scm_t_array_dim
*s
, *r
;
474 SCM_VALIDATE_REST_ARGUMENT (args
);
475 SCM_ASSERT (SCM_HEAP_OBJECT_P (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
477 if (scm_is_generalized_vector (ra
))
479 /* Make sure that we are called with a single zero as
482 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
483 SCM_WRONG_NUM_ARGS ();
484 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
485 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
489 if (SCM_I_ARRAYP (ra
))
491 vargs
= scm_vector (args
);
492 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
493 SCM_WRONG_NUM_ARGS ();
495 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
497 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
498 0, SCM_I_ARRAY_NDIM(ra
));
503 res
= scm_i_make_array (ndim
);
504 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
505 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
508 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
509 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
511 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
513 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
514 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
515 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
516 if (r
->ubnd
< r
->lbnd
)
525 if (r
->ubnd
> s
->ubnd
)
527 if (r
->lbnd
< s
->lbnd
)
529 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
536 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
537 scm_i_ra_set_contp (res
);
541 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
545 /* attempts to unroll an array into a one-dimensional array.
546 returns the unrolled array or #f if it can't be done. */
547 /* if strict is not SCM_UNDEFINED, return #f if returned array
548 wouldn't have contiguous elements. */
549 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
550 (SCM ra
, SCM strict
),
551 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
552 "without changing their order (last subscript changing fastest), then\n"
553 "@code{array-contents} returns that shared array, otherwise it returns\n"
554 "@code{#f}. All arrays made by @var{make-array} and\n"
555 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
556 "@var{make-shared-array} may not be.\n\n"
557 "If the optional argument @var{strict} is provided, a shared array will\n"
558 "be returned only if its elements are stored internally contiguous in\n"
560 #define FUNC_NAME s_scm_array_contents
564 if (scm_is_generalized_vector (ra
))
567 if (SCM_I_ARRAYP (ra
))
569 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
570 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
572 for (k
= 0; k
< ndim
; k
++)
573 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
574 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
576 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
578 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
580 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
581 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
588 SCM v
= SCM_I_ARRAY_V (ra
);
589 size_t length
= scm_c_generalized_vector_length (v
);
590 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
594 sra
= scm_i_make_array (1);
595 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
596 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
597 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
598 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
599 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
603 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
609 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
611 if (k
== scm_array_handle_rank (handle
))
612 scm_array_handle_set (handle
, pos
, lst
);
615 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
616 ssize_t inc
= dim
->inc
;
617 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
621 while (n
> 0 && scm_is_pair (lst
))
623 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
629 errmsg
= "too few elements for array dimension ~a, need ~a";
630 if (!scm_is_null (lst
))
631 errmsg
= "too many elements for array dimension ~a, want ~a";
633 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
634 scm_from_size_t (len
)));
639 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
640 (SCM type
, SCM shape
, SCM lst
),
641 "Return an array of the type @var{type}\n"
642 "with elements the same as those of @var{lst}.\n"
644 "The argument @var{shape} determines the number of dimensions\n"
645 "of the array and their shape. It is either an exact integer,\n"
647 "number of dimensions directly, or a list whose length\n"
648 "specifies the number of dimensions and each element specified\n"
649 "the lower and optionally the upper bound of the corresponding\n"
651 "When the element is list of two elements, these elements\n"
652 "give the lower and upper bounds. When it is an exact\n"
653 "integer, it gives only the lower bound.")
654 #define FUNC_NAME s_scm_list_to_typed_array
658 scm_t_array_handle handle
;
661 if (scm_is_integer (shape
))
663 size_t k
= scm_to_size_t (shape
);
667 shape
= scm_cons (scm_length (row
), shape
);
668 if (k
> 0 && !scm_is_null (row
))
674 SCM shape_spec
= shape
;
678 SCM spec
= scm_car (shape_spec
);
679 if (scm_is_pair (spec
))
680 shape
= scm_cons (spec
, shape
);
682 shape
= scm_cons (scm_list_2 (spec
,
683 scm_sum (scm_sum (spec
,
687 shape_spec
= scm_cdr (shape_spec
);
688 if (scm_is_pair (shape_spec
))
690 if (!scm_is_null (row
))
698 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
699 scm_reverse_x (shape
, SCM_EOL
));
701 scm_array_get_handle (ra
, &handle
);
702 list_to_array (lst
, &handle
, 0, 0);
703 scm_array_handle_release (&handle
);
709 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
711 "Return an array with elements the same as those of @var{lst}.")
712 #define FUNC_NAME s_scm_list_to_array
714 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
718 /* Print dimension DIM of ARRAY.
722 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
723 SCM port
, scm_print_state
*pstate
)
726 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
730 scm_putc_unlocked ('(', port
);
731 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
732 i
++, pos
+= h
->dims
[dim
].inc
)
734 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
735 if (i
< h
->dims
[dim
].ubnd
)
736 scm_putc_unlocked (' ', port
);
738 scm_putc_unlocked (')', port
);
747 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
749 scm_t_array_handle h
;
751 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
753 scm_array_get_handle (array
, &h
);
755 scm_putc_unlocked ('#', port
);
756 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
757 scm_intprint (h
.ndims
, 10, port
);
758 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
759 scm_write (scm_array_handle_element_type (&h
), port
);
761 for (i
= 0; i
< h
.ndims
; i
++)
763 if (h
.dims
[i
].lbnd
!= 0)
765 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
771 if (print_lbnds
|| print_lens
)
772 for (i
= 0; i
< h
.ndims
; i
++)
776 scm_putc_unlocked ('@', port
);
777 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
781 scm_putc_unlocked (':', port
);
782 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
789 /* Rank zero arrays, which are really just scalars, are printed
790 specially. The consequent way would be to print them as
794 where OBJ is the printed representation of the scalar, but we
795 print them instead as
799 to make them look less strange.
801 Just printing them as
805 would be correct in a way as well, but zero rank arrays are
806 not really the same as Scheme values since they are boxed and
807 can be modified with array-set!, say.
809 scm_putc_unlocked ('(', port
);
810 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
811 scm_putc_unlocked (')', port
);
815 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
818 /* Read an array. This function can also read vectors and uniform
819 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
822 C is the first character read after the '#'.
826 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
835 c
= scm_getc_unlocked (port
);
838 while ('0' <= c
&& c
<= '9')
840 res
= 10*res
+ c
-'0';
842 c
= scm_getc_unlocked (port
);
851 scm_i_read_array (SCM port
, int c
)
854 scm_t_wchar tag_buf
[8];
857 SCM tag
, shape
= SCM_BOOL_F
, elements
;
859 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
860 the array code can not deal with zero-length dimensions yet, and
861 we want to allow zero-length vectors, of course.
865 scm_ungetc_unlocked (c
, port
);
866 return scm_vector (scm_read (port
));
869 /* Disambiguate between '#f' and uniform floating point vectors.
873 c
= scm_getc_unlocked (port
);
874 if (c
!= '3' && c
!= '6')
877 scm_ungetc_unlocked (c
, port
);
883 goto continue_reading_tag
;
889 c
= read_decimal_integer (port
, c
, &rank
);
891 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
897 continue_reading_tag
:
898 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':'
899 && tag_len
< sizeof tag_buf
/ sizeof tag_buf
[0])
901 tag_buf
[tag_len
++] = c
;
902 c
= scm_getc_unlocked (port
);
908 tag
= scm_string_to_symbol (scm_from_utf32_stringn (tag_buf
, tag_len
));
909 if (tag_len
== sizeof tag_buf
/ sizeof tag_buf
[0])
910 scm_i_input_error (NULL
, port
, "invalid array tag, starting with: ~a",
916 if (c
== '@' || c
== ':')
922 ssize_t lbnd
= 0, len
= 0;
927 c
= scm_getc_unlocked (port
);
928 c
= read_decimal_integer (port
, c
, &lbnd
);
931 s
= scm_from_ssize_t (lbnd
);
935 c
= scm_getc_unlocked (port
);
936 c
= read_decimal_integer (port
, c
, &len
);
938 scm_i_input_error (NULL
, port
,
939 "array length must be non-negative",
942 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
945 shape
= scm_cons (s
, shape
);
946 } while (c
== '@' || c
== ':');
948 shape
= scm_reverse_x (shape
, SCM_EOL
);
951 /* Read nested lists of elements.
954 scm_i_input_error (NULL
, port
,
955 "missing '(' in vector or array literal",
957 scm_ungetc_unlocked (c
, port
);
958 elements
= scm_read (port
);
960 if (scm_is_false (shape
))
961 shape
= scm_from_ssize_t (rank
);
962 else if (scm_ilength (shape
) != rank
)
965 "the number of shape specifications must match the array rank",
968 /* Handle special print syntax of rank zero arrays; see
969 scm_i_print_array for a rationale.
973 if (!scm_is_pair (elements
))
974 scm_i_input_error (NULL
, port
,
975 "too few elements in array literal, need 1",
977 if (!scm_is_null (SCM_CDR (elements
)))
978 scm_i_input_error (NULL
, port
,
979 "too many elements in array literal, want 1",
981 elements
= SCM_CAR (elements
);
986 return scm_list_to_typed_array (tag
, shape
, elements
);
991 array_handle_ref (scm_t_array_handle
*h
, size_t pos
)
993 return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h
->array
), pos
);
997 array_handle_set (scm_t_array_handle
*h
, size_t pos
, SCM val
)
999 scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
1002 /* FIXME: should be handle for vect? maybe not, because of dims */
1004 array_get_handle (SCM array
, scm_t_array_handle
*h
)
1006 scm_t_array_handle vh
;
1007 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
1008 h
->element_type
= vh
.element_type
;
1009 h
->elements
= vh
.elements
;
1010 h
->writable_elements
= vh
.writable_elements
;
1011 scm_array_handle_release (&vh
);
1013 h
->dims
= SCM_I_ARRAY_DIMS (array
);
1014 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
1015 h
->base
= SCM_I_ARRAY_BASE (array
);
1018 SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array
),
1020 array_handle_ref
, array_handle_set
,
1026 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
1027 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
1028 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
1030 scm_add_feature ("array");
1032 #include "libguile/arrays.x"