1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 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
);
263 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
264 (SCM fill
, SCM bounds
),
265 "Create and return an array.")
266 #define FUNC_NAME s_scm_make_array
268 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
273 scm_i_ra_set_contp (SCM ra
)
275 size_t k
= SCM_I_ARRAY_NDIM (ra
);
278 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
281 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
283 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
286 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
287 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
290 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
294 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
295 (SCM oldra
, SCM mapfunc
, SCM dims
),
296 "@code{make-shared-array} can be used to create shared subarrays of other\n"
297 "arrays. The @var{mapper} is a function that translates coordinates in\n"
298 "the new array into coordinates in the old array. A @var{mapper} must be\n"
299 "linear, and its range must stay within the bounds of the old array, but\n"
300 "it can be otherwise arbitrary. A simple example:\n"
302 "(define fred (make-array #f 8 8))\n"
303 "(define freds-diagonal\n"
304 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
305 "(array-set! freds-diagonal 'foo 3)\n"
306 "(array-ref fred 3 3) @result{} foo\n"
307 "(define freds-center\n"
308 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
309 "(array-ref freds-center 0 0) @result{} foo\n"
311 #define FUNC_NAME s_scm_make_shared_array
313 scm_t_array_handle old_handle
;
319 long old_base
, old_min
, new_min
, old_max
, new_max
;
322 SCM_VALIDATE_REST_ARGUMENT (dims
);
323 SCM_VALIDATE_PROC (2, mapfunc
);
324 ra
= scm_i_shap2ra (dims
);
326 scm_array_get_handle (oldra
, &old_handle
);
328 if (SCM_I_ARRAYP (oldra
))
330 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
331 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
332 s
= scm_array_handle_dims (&old_handle
);
333 k
= scm_array_handle_rank (&old_handle
);
337 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
339 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
344 SCM_I_ARRAY_V (ra
) = oldra
;
345 old_base
= old_min
= 0;
346 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
350 s
= SCM_I_ARRAY_DIMS (ra
);
351 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
353 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
354 if (s
[k
].ubnd
< s
[k
].lbnd
)
356 if (1 == SCM_I_ARRAY_NDIM (ra
))
357 ra
= scm_make_generalized_vector (scm_array_type (ra
),
358 SCM_INUM0
, SCM_UNDEFINED
);
361 scm_make_generalized_vector (scm_array_type (ra
),
362 SCM_INUM0
, SCM_UNDEFINED
);
363 scm_array_handle_release (&old_handle
);
368 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
369 i
= scm_array_handle_pos (&old_handle
, imap
);
370 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
372 k
= SCM_I_ARRAY_NDIM (ra
);
375 if (s
[k
].ubnd
> s
[k
].lbnd
)
377 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
378 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
379 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
382 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
384 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
387 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
388 indptr
= SCM_CDR (indptr
);
391 scm_array_handle_release (&old_handle
);
393 if (old_min
> new_min
|| old_max
< new_max
)
394 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
395 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
397 SCM v
= SCM_I_ARRAY_V (ra
);
398 size_t length
= scm_c_generalized_vector_length (v
);
399 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
401 if (s
->ubnd
< s
->lbnd
)
402 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
405 scm_i_ra_set_contp (ra
);
411 /* args are RA . DIMS */
412 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
414 "Return an array sharing contents with @var{array}, but with\n"
415 "dimensions arranged in a different order. There must be one\n"
416 "@var{dim} argument for each dimension of @var{array}.\n"
417 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
418 "and the rank of the array to be returned. Each integer in that\n"
419 "range must appear at least once in the argument list.\n"
421 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
422 "dimensions in the array to be returned, their positions in the\n"
423 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
424 "may have the same value, in which case the returned array will\n"
425 "have smaller rank than @var{array}.\n"
428 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
429 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
430 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
431 " #2((a 4) (b 5) (c 6))\n"
433 #define FUNC_NAME s_scm_transpose_array
436 scm_t_array_dim
*s
, *r
;
439 SCM_VALIDATE_REST_ARGUMENT (args
);
440 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
442 if (scm_is_generalized_vector (ra
))
444 /* Make sure that we are called with a single zero as
447 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
448 SCM_WRONG_NUM_ARGS ();
449 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
450 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
454 if (SCM_I_ARRAYP (ra
))
456 vargs
= scm_vector (args
);
457 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
458 SCM_WRONG_NUM_ARGS ();
460 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
462 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
463 0, SCM_I_ARRAY_NDIM(ra
));
468 res
= scm_i_make_array (ndim
);
469 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
470 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
473 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
474 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
476 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
478 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
479 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
480 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
481 if (r
->ubnd
< r
->lbnd
)
490 if (r
->ubnd
> s
->ubnd
)
492 if (r
->lbnd
< s
->lbnd
)
494 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
501 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
502 scm_i_ra_set_contp (res
);
506 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
510 /* attempts to unroll an array into a one-dimensional array.
511 returns the unrolled array or #f if it can't be done. */
512 /* if strict is not SCM_UNDEFINED, return #f if returned array
513 wouldn't have contiguous elements. */
514 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
515 (SCM ra
, SCM strict
),
516 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
517 "without changing their order (last subscript changing fastest), then\n"
518 "@code{array-contents} returns that shared array, otherwise it returns\n"
519 "@code{#f}. All arrays made by @var{make-array} and\n"
520 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
521 "@var{make-shared-array} may not be.\n\n"
522 "If the optional argument @var{strict} is provided, a shared array will\n"
523 "be returned only if its elements are stored internally contiguous in\n"
525 #define FUNC_NAME s_scm_array_contents
529 if (scm_is_generalized_vector (ra
))
532 if (SCM_I_ARRAYP (ra
))
534 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
535 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
537 for (k
= 0; k
< ndim
; k
++)
538 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
539 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
541 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
543 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
545 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
546 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
553 SCM v
= SCM_I_ARRAY_V (ra
);
554 size_t length
= scm_c_generalized_vector_length (v
);
555 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
559 sra
= scm_i_make_array (1);
560 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
561 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
562 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
563 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
564 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
568 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
574 scm_ra2contig (SCM ra
, int copy
)
579 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
580 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
581 k
= SCM_I_ARRAY_NDIM (ra
);
582 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
584 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
586 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
587 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
588 0 == len
% SCM_LONG_BIT
))
591 ret
= scm_i_make_array (k
);
592 SCM_I_ARRAY_BASE (ret
) = 0;
595 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
596 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
597 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
598 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
600 SCM_I_ARRAY_V (ret
) = scm_make_generalized_vector (scm_array_type (ra
),
604 scm_array_copy_x (ra
, ret
);
610 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
611 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
612 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
613 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
614 "binary objects from @var{port-or-fdes}.\n"
615 "If an end of file is encountered,\n"
616 "the objects up to that point are put into @var{ura}\n"
617 "(starting at the beginning) and the remainder of the array is\n"
619 "The optional arguments @var{start} and @var{end} allow\n"
620 "a specified region of a vector (or linearized array) to be read,\n"
621 "leaving the remainder of the vector unchanged.\n\n"
622 "@code{uniform-array-read!} returns the number of objects read.\n"
623 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
624 "returned by @code{(current-input-port)}.")
625 #define FUNC_NAME s_scm_uniform_array_read_x
627 if (SCM_UNBNDP (port_or_fd
))
628 port_or_fd
= scm_current_input_port ();
630 if (scm_is_uniform_vector (ura
))
632 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
634 else if (SCM_I_ARRAYP (ura
))
636 size_t base
, vlen
, cstart
, cend
;
639 cra
= scm_ra2contig (ura
, 0);
640 base
= SCM_I_ARRAY_BASE (cra
);
641 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
642 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
646 if (!SCM_UNBNDP (start
))
648 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
649 if (!SCM_UNBNDP (end
))
650 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
653 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
654 scm_from_size_t (base
+ cstart
),
655 scm_from_size_t (base
+ cend
));
657 if (!scm_is_eq (cra
, ura
))
658 scm_array_copy_x (cra
, ura
);
662 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
666 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
667 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
668 "Writes all elements of @var{ura} as binary objects to\n"
669 "@var{port-or-fdes}.\n\n"
670 "The optional arguments @var{start}\n"
671 "and @var{end} allow\n"
672 "a specified region of a vector (or linearized array) to be written.\n\n"
673 "The number of objects actually written is returned.\n"
674 "@var{port-or-fdes} may be\n"
675 "omitted, in which case it defaults to the value returned by\n"
676 "@code{(current-output-port)}.")
677 #define FUNC_NAME s_scm_uniform_array_write
679 if (SCM_UNBNDP (port_or_fd
))
680 port_or_fd
= scm_current_output_port ();
682 if (scm_is_uniform_vector (ura
))
684 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
686 else if (SCM_I_ARRAYP (ura
))
688 size_t base
, vlen
, cstart
, cend
;
691 cra
= scm_ra2contig (ura
, 1);
692 base
= SCM_I_ARRAY_BASE (cra
);
693 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
694 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
698 if (!SCM_UNBNDP (start
))
700 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
701 if (!SCM_UNBNDP (end
))
702 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
705 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
706 scm_from_size_t (base
+ cstart
),
707 scm_from_size_t (base
+ cend
));
712 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
718 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
720 if (k
== scm_array_handle_rank (handle
))
721 scm_array_handle_set (handle
, pos
, lst
);
724 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
725 ssize_t inc
= dim
->inc
;
726 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
730 while (n
> 0 && scm_is_pair (lst
))
732 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
738 errmsg
= "too few elements for array dimension ~a, need ~a";
739 if (!scm_is_null (lst
))
740 errmsg
= "too many elements for array dimension ~a, want ~a";
742 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
743 scm_from_size_t (len
)));
748 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
749 (SCM type
, SCM shape
, SCM lst
),
750 "Return an array of the type @var{type}\n"
751 "with elements the same as those of @var{lst}.\n"
753 "The argument @var{shape} determines the number of dimensions\n"
754 "of the array and their shape. It is either an exact integer,\n"
756 "number of dimensions directly, or a list whose length\n"
757 "specifies the number of dimensions and each element specified\n"
758 "the lower and optionally the upper bound of the corresponding\n"
760 "When the element is list of two elements, these elements\n"
761 "give the lower and upper bounds. When it is an exact\n"
762 "integer, it gives only the lower bound.")
763 #define FUNC_NAME s_scm_list_to_typed_array
767 scm_t_array_handle handle
;
770 if (scm_is_integer (shape
))
772 size_t k
= scm_to_size_t (shape
);
776 shape
= scm_cons (scm_length (row
), shape
);
777 if (k
> 0 && !scm_is_null (row
))
783 SCM shape_spec
= shape
;
787 SCM spec
= scm_car (shape_spec
);
788 if (scm_is_pair (spec
))
789 shape
= scm_cons (spec
, shape
);
791 shape
= scm_cons (scm_list_2 (spec
,
792 scm_sum (scm_sum (spec
,
796 shape_spec
= scm_cdr (shape_spec
);
797 if (scm_is_pair (shape_spec
))
799 if (!scm_is_null (row
))
807 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
808 scm_reverse_x (shape
, SCM_EOL
));
810 scm_array_get_handle (ra
, &handle
);
811 list_to_array (lst
, &handle
, 0, 0);
812 scm_array_handle_release (&handle
);
818 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
820 "Return an array with elements the same as those of @var{lst}.")
821 #define FUNC_NAME s_scm_list_to_array
823 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
827 /* Print dimension DIM of ARRAY.
831 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
832 SCM port
, scm_print_state
*pstate
)
835 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
839 scm_putc ('(', port
);
840 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
841 i
++, pos
+= h
->dims
[dim
].inc
)
843 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
844 if (i
< h
->dims
[dim
].ubnd
)
845 scm_putc (' ', port
);
847 scm_putc (')', port
);
856 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
858 scm_t_array_handle h
;
860 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
862 scm_array_get_handle (array
, &h
);
864 scm_putc ('#', port
);
865 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
866 scm_intprint (h
.ndims
, 10, port
);
867 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
868 scm_write (scm_array_handle_element_type (&h
), port
);
870 for (i
= 0; i
< h
.ndims
; i
++)
872 if (h
.dims
[i
].lbnd
!= 0)
874 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
880 if (print_lbnds
|| print_lens
)
881 for (i
= 0; i
< h
.ndims
; i
++)
885 scm_putc ('@', port
);
886 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
890 scm_putc (':', port
);
891 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
898 /* Rank zero arrays, which are really just scalars, are printed
899 specially. The consequent way would be to print them as
903 where OBJ is the printed representation of the scalar, but we
904 print them instead as
908 to make them look less strange.
910 Just printing them as
914 would be correct in a way as well, but zero rank arrays are
915 not really the same as Scheme values since they are boxed and
916 can be modified with array-set!, say.
918 scm_putc ('(', port
);
919 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
920 scm_putc (')', port
);
924 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
927 /* Read an array. This function can also read vectors and uniform
928 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
931 C is the first character read after the '#'.
935 tag_to_type (const char *tag
, SCM port
)
940 return scm_from_locale_symbol (tag
);
944 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
956 while ('0' <= c
&& c
<= '9')
958 res
= 10*res
+ c
-'0';
969 scm_i_read_array (SCM port
, int c
)
976 SCM shape
= SCM_BOOL_F
, elements
;
978 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
979 the array code can not deal with zero-length dimensions yet, and
980 we want to allow zero-length vectors, of course.
984 scm_ungetc (c
, port
);
985 return scm_vector (scm_read (port
));
988 /* Disambiguate between '#f' and uniform floating point vectors.
993 if (c
!= '3' && c
!= '6')
996 scm_ungetc (c
, port
);
1003 goto continue_reading_tag
;
1009 c
= read_decimal_integer (port
, c
, &rank
);
1011 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
1017 continue_reading_tag
:
1018 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
1021 c
= scm_getc (port
);
1023 tag
[tag_len
] = '\0';
1027 if (c
== '@' || c
== ':')
1033 ssize_t lbnd
= 0, len
= 0;
1038 c
= scm_getc (port
);
1039 c
= read_decimal_integer (port
, c
, &lbnd
);
1042 s
= scm_from_ssize_t (lbnd
);
1046 c
= scm_getc (port
);
1047 c
= read_decimal_integer (port
, c
, &len
);
1049 scm_i_input_error (NULL
, port
,
1050 "array length must be non-negative",
1053 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
1056 shape
= scm_cons (s
, shape
);
1057 } while (c
== '@' || c
== ':');
1059 shape
= scm_reverse_x (shape
, SCM_EOL
);
1062 /* Read nested lists of elements.
1065 scm_i_input_error (NULL
, port
,
1066 "missing '(' in vector or array literal",
1068 scm_ungetc (c
, port
);
1069 elements
= scm_read (port
);
1071 if (scm_is_false (shape
))
1072 shape
= scm_from_ssize_t (rank
);
1073 else if (scm_ilength (shape
) != rank
)
1076 "the number of shape specifications must match the array rank",
1079 /* Handle special print syntax of rank zero arrays; see
1080 scm_i_print_array for a rationale.
1084 if (!scm_is_pair (elements
))
1085 scm_i_input_error (NULL
, port
,
1086 "too few elements in array literal, need 1",
1088 if (!scm_is_null (SCM_CDR (elements
)))
1089 scm_i_input_error (NULL
, port
,
1090 "too many elements in array literal, want 1",
1092 elements
= SCM_CAR (elements
);
1097 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
1102 array_handle_ref (scm_t_array_handle
*h
, size_t pos
)
1104 return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h
->array
), pos
);
1108 array_handle_set (scm_t_array_handle
*h
, size_t pos
, SCM val
)
1110 scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
1113 /* FIXME: should be handle for vect? maybe not, because of dims */
1115 array_get_handle (SCM array
, scm_t_array_handle
*h
)
1117 scm_t_array_handle vh
;
1118 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
1119 h
->element_type
= vh
.element_type
;
1120 h
->elements
= vh
.elements
;
1121 h
->writable_elements
= vh
.writable_elements
;
1122 scm_array_handle_release (&vh
);
1124 h
->dims
= SCM_I_ARRAY_DIMS (array
);
1125 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
1126 h
->base
= SCM_I_ARRAY_BASE (array
);
1129 SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array
),
1131 array_handle_ref
, array_handle_set
,
1137 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
1138 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
1139 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
1141 scm_add_feature ("array");
1143 #include "libguile/arrays.x"