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_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
60 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
61 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
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 base
= scm_array_handle_uniform_writable_elements (&h
);
234 sz
= scm_array_handle_uniform_element_size (&h
);
235 scm_array_handle_release (&h
);
238 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
239 if (byte_len
/ sz
!= rlen
)
240 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
242 memcpy (base
, bytes
, byte_len
);
244 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
245 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
246 return SCM_I_ARRAY_V (ra
);
251 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
252 (SCM fill
, SCM bounds
),
253 "Create and return an array.")
254 #define FUNC_NAME s_scm_make_array
256 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
261 scm_i_ra_set_contp (SCM ra
)
263 size_t k
= SCM_I_ARRAY_NDIM (ra
);
266 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
269 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
271 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
274 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
275 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
278 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
282 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
283 (SCM oldra
, SCM mapfunc
, SCM dims
),
284 "@code{make-shared-array} can be used to create shared subarrays of other\n"
285 "arrays. The @var{mapper} is a function that translates coordinates in\n"
286 "the new array into coordinates in the old array. A @var{mapper} must be\n"
287 "linear, and its range must stay within the bounds of the old array, but\n"
288 "it can be otherwise arbitrary. A simple example:\n"
290 "(define fred (make-array #f 8 8))\n"
291 "(define freds-diagonal\n"
292 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
293 "(array-set! freds-diagonal 'foo 3)\n"
294 "(array-ref fred 3 3) @result{} foo\n"
295 "(define freds-center\n"
296 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
297 "(array-ref freds-center 0 0) @result{} foo\n"
299 #define FUNC_NAME s_scm_make_shared_array
301 scm_t_array_handle old_handle
;
307 long old_base
, old_min
, new_min
, old_max
, new_max
;
310 SCM_VALIDATE_REST_ARGUMENT (dims
);
311 SCM_VALIDATE_PROC (2, mapfunc
);
312 ra
= scm_i_shap2ra (dims
);
314 scm_array_get_handle (oldra
, &old_handle
);
316 if (SCM_I_ARRAYP (oldra
))
318 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
319 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
320 s
= scm_array_handle_dims (&old_handle
);
321 k
= scm_array_handle_rank (&old_handle
);
325 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
327 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
332 SCM_I_ARRAY_V (ra
) = oldra
;
333 old_base
= old_min
= 0;
334 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
338 s
= SCM_I_ARRAY_DIMS (ra
);
339 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
341 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
342 if (s
[k
].ubnd
< s
[k
].lbnd
)
344 if (1 == SCM_I_ARRAY_NDIM (ra
))
345 ra
= scm_make_generalized_vector (scm_array_type (ra
),
346 SCM_INUM0
, SCM_UNDEFINED
);
349 scm_make_generalized_vector (scm_array_type (ra
),
350 SCM_INUM0
, SCM_UNDEFINED
);
351 scm_array_handle_release (&old_handle
);
356 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
357 i
= scm_array_handle_pos (&old_handle
, imap
);
358 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
360 k
= SCM_I_ARRAY_NDIM (ra
);
363 if (s
[k
].ubnd
> s
[k
].lbnd
)
365 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
366 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
367 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
370 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
372 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
375 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
376 indptr
= SCM_CDR (indptr
);
379 scm_array_handle_release (&old_handle
);
381 if (old_min
> new_min
|| old_max
< new_max
)
382 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
383 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
385 SCM v
= SCM_I_ARRAY_V (ra
);
386 size_t length
= scm_c_generalized_vector_length (v
);
387 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
389 if (s
->ubnd
< s
->lbnd
)
390 return scm_make_generalized_vector (scm_array_type (ra
), SCM_INUM0
,
393 scm_i_ra_set_contp (ra
);
399 /* args are RA . DIMS */
400 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
402 "Return an array sharing contents with @var{array}, but with\n"
403 "dimensions arranged in a different order. There must be one\n"
404 "@var{dim} argument for each dimension of @var{array}.\n"
405 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
406 "and the rank of the array to be returned. Each integer in that\n"
407 "range must appear at least once in the argument list.\n"
409 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
410 "dimensions in the array to be returned, their positions in the\n"
411 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
412 "may have the same value, in which case the returned array will\n"
413 "have smaller rank than @var{array}.\n"
416 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
417 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
418 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
419 " #2((a 4) (b 5) (c 6))\n"
421 #define FUNC_NAME s_scm_transpose_array
424 scm_t_array_dim
*s
, *r
;
427 SCM_VALIDATE_REST_ARGUMENT (args
);
428 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
430 if (scm_is_generalized_vector (ra
))
432 /* Make sure that we are called with a single zero as
435 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
436 SCM_WRONG_NUM_ARGS ();
437 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
438 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
442 if (SCM_I_ARRAYP (ra
))
444 vargs
= scm_vector (args
);
445 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
446 SCM_WRONG_NUM_ARGS ();
448 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
450 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
451 0, SCM_I_ARRAY_NDIM(ra
));
456 res
= scm_i_make_array (ndim
);
457 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
458 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
461 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
462 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
464 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
466 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
467 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
468 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
469 if (r
->ubnd
< r
->lbnd
)
478 if (r
->ubnd
> s
->ubnd
)
480 if (r
->lbnd
< s
->lbnd
)
482 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
489 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
490 scm_i_ra_set_contp (res
);
494 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
498 /* attempts to unroll an array into a one-dimensional array.
499 returns the unrolled array or #f if it can't be done. */
500 /* if strict is not SCM_UNDEFINED, return #f if returned array
501 wouldn't have contiguous elements. */
502 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
503 (SCM ra
, SCM strict
),
504 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
505 "without changing their order (last subscript changing fastest), then\n"
506 "@code{array-contents} returns that shared array, otherwise it returns\n"
507 "@code{#f}. All arrays made by @var{make-array} and\n"
508 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
509 "@var{make-shared-array} may not be.\n\n"
510 "If the optional argument @var{strict} is provided, a shared array will\n"
511 "be returned only if its elements are stored internally contiguous in\n"
513 #define FUNC_NAME s_scm_array_contents
517 if (scm_is_generalized_vector (ra
))
520 if (SCM_I_ARRAYP (ra
))
522 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
523 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
525 for (k
= 0; k
< ndim
; k
++)
526 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
527 if (!SCM_UNBNDP (strict
) && scm_is_true (strict
))
529 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
531 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
533 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
534 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
541 SCM v
= SCM_I_ARRAY_V (ra
);
542 size_t length
= scm_c_generalized_vector_length (v
);
543 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
547 sra
= scm_i_make_array (1);
548 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
549 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
550 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
551 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
552 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
556 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
562 scm_ra2contig (SCM ra
, int copy
)
567 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
568 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
569 k
= SCM_I_ARRAY_NDIM (ra
);
570 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
572 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
574 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
575 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
576 0 == len
% SCM_LONG_BIT
))
579 ret
= scm_i_make_array (k
);
580 SCM_I_ARRAY_BASE (ret
) = 0;
583 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
584 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
585 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
586 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
588 SCM_I_ARRAY_V (ret
) = scm_make_generalized_vector (scm_array_type (ra
),
592 scm_array_copy_x (ra
, ret
);
598 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
599 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
600 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
601 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
602 "binary objects from @var{port-or-fdes}.\n"
603 "If an end of file is encountered,\n"
604 "the objects up to that point are put into @var{ura}\n"
605 "(starting at the beginning) and the remainder of the array is\n"
607 "The optional arguments @var{start} and @var{end} allow\n"
608 "a specified region of a vector (or linearized array) to be read,\n"
609 "leaving the remainder of the vector unchanged.\n\n"
610 "@code{uniform-array-read!} returns the number of objects read.\n"
611 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
612 "returned by @code{(current-input-port)}.")
613 #define FUNC_NAME s_scm_uniform_array_read_x
615 if (SCM_UNBNDP (port_or_fd
))
616 port_or_fd
= scm_current_input_port ();
618 if (scm_is_uniform_vector (ura
))
620 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
622 else if (SCM_I_ARRAYP (ura
))
624 size_t base
, vlen
, cstart
, cend
;
627 cra
= scm_ra2contig (ura
, 0);
628 base
= SCM_I_ARRAY_BASE (cra
);
629 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
630 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
634 if (!SCM_UNBNDP (start
))
636 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
637 if (!SCM_UNBNDP (end
))
638 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
641 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
642 scm_from_size_t (base
+ cstart
),
643 scm_from_size_t (base
+ cend
));
645 if (!scm_is_eq (cra
, ura
))
646 scm_array_copy_x (cra
, ura
);
650 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
654 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
655 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
656 "Writes all elements of @var{ura} as binary objects to\n"
657 "@var{port-or-fdes}.\n\n"
658 "The optional arguments @var{start}\n"
659 "and @var{end} allow\n"
660 "a specified region of a vector (or linearized array) to be written.\n\n"
661 "The number of objects actually written is returned.\n"
662 "@var{port-or-fdes} may be\n"
663 "omitted, in which case it defaults to the value returned by\n"
664 "@code{(current-output-port)}.")
665 #define FUNC_NAME s_scm_uniform_array_write
667 if (SCM_UNBNDP (port_or_fd
))
668 port_or_fd
= scm_current_output_port ();
670 if (scm_is_uniform_vector (ura
))
672 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
674 else if (SCM_I_ARRAYP (ura
))
676 size_t base
, vlen
, cstart
, cend
;
679 cra
= scm_ra2contig (ura
, 1);
680 base
= SCM_I_ARRAY_BASE (cra
);
681 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
682 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
686 if (!SCM_UNBNDP (start
))
688 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
689 if (!SCM_UNBNDP (end
))
690 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
693 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
694 scm_from_size_t (base
+ cstart
),
695 scm_from_size_t (base
+ cend
));
700 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
706 list_to_array (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
708 if (k
== scm_array_handle_rank (handle
))
709 scm_array_handle_set (handle
, pos
, lst
);
712 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
713 ssize_t inc
= dim
->inc
;
714 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
718 while (n
> 0 && scm_is_pair (lst
))
720 list_to_array (SCM_CAR (lst
), handle
, pos
, k
+ 1);
726 errmsg
= "too few elements for array dimension ~a, need ~a";
727 if (!scm_is_null (lst
))
728 errmsg
= "too many elements for array dimension ~a, want ~a";
730 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
731 scm_from_size_t (len
)));
736 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
737 (SCM type
, SCM shape
, SCM lst
),
738 "Return an array of the type @var{type}\n"
739 "with elements the same as those of @var{lst}.\n"
741 "The argument @var{shape} determines the number of dimensions\n"
742 "of the array and their shape. It is either an exact integer,\n"
744 "number of dimensions directly, or a list whose length\n"
745 "specifies the number of dimensions and each element specified\n"
746 "the lower and optionally the upper bound of the corresponding\n"
748 "When the element is list of two elements, these elements\n"
749 "give the lower and upper bounds. When it is an exact\n"
750 "integer, it gives only the lower bound.")
751 #define FUNC_NAME s_scm_list_to_typed_array
755 scm_t_array_handle handle
;
758 if (scm_is_integer (shape
))
760 size_t k
= scm_to_size_t (shape
);
764 shape
= scm_cons (scm_length (row
), shape
);
765 if (k
> 0 && !scm_is_null (row
))
771 SCM shape_spec
= shape
;
775 SCM spec
= scm_car (shape_spec
);
776 if (scm_is_pair (spec
))
777 shape
= scm_cons (spec
, shape
);
779 shape
= scm_cons (scm_list_2 (spec
,
780 scm_sum (scm_sum (spec
,
784 shape_spec
= scm_cdr (shape_spec
);
785 if (scm_is_pair (shape_spec
))
787 if (!scm_is_null (row
))
795 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
796 scm_reverse_x (shape
, SCM_EOL
));
798 scm_array_get_handle (ra
, &handle
);
799 list_to_array (lst
, &handle
, 0, 0);
800 scm_array_handle_release (&handle
);
806 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
808 "Return an array with elements the same as those of @var{lst}.")
809 #define FUNC_NAME s_scm_list_to_array
811 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
815 /* Print dimension DIM of ARRAY.
819 scm_i_print_array_dimension (scm_t_array_handle
*h
, int dim
, int pos
,
820 SCM port
, scm_print_state
*pstate
)
823 scm_iprin1 (scm_array_handle_ref (h
, pos
), port
, pstate
);
827 scm_putc ('(', port
);
828 for (i
= h
->dims
[dim
].lbnd
; i
<= h
->dims
[dim
].ubnd
;
829 i
++, pos
+= h
->dims
[dim
].inc
)
831 scm_i_print_array_dimension (h
, dim
+1, pos
, port
, pstate
);
832 if (i
< h
->dims
[dim
].ubnd
)
833 scm_putc (' ', port
);
835 scm_putc (')', port
);
844 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
846 scm_t_array_handle h
;
848 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
850 scm_array_get_handle (array
, &h
);
852 scm_putc ('#', port
);
853 if (h
.ndims
!= 1 || h
.dims
[0].lbnd
!= 0)
854 scm_intprint (h
.ndims
, 10, port
);
855 if (h
.element_type
!= SCM_ARRAY_ELEMENT_TYPE_SCM
)
856 scm_write (scm_array_handle_element_type (&h
), port
);
858 for (i
= 0; i
< h
.ndims
; i
++)
860 if (h
.dims
[i
].lbnd
!= 0)
862 if (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1 == 0)
868 if (print_lbnds
|| print_lens
)
869 for (i
= 0; i
< h
.ndims
; i
++)
873 scm_putc ('@', port
);
874 scm_intprint (h
.dims
[i
].lbnd
, 10, port
);
878 scm_putc (':', port
);
879 scm_intprint (h
.dims
[i
].ubnd
- h
.dims
[i
].lbnd
+ 1,
886 /* Rank zero arrays, which are really just scalars, are printed
887 specially. The consequent way would be to print them as
891 where OBJ is the printed representation of the scalar, but we
892 print them instead as
896 to make them look less strange.
898 Just printing them as
902 would be correct in a way as well, but zero rank arrays are
903 not really the same as Scheme values since they are boxed and
904 can be modified with array-set!, say.
906 scm_putc ('(', port
);
907 scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
908 scm_putc (')', port
);
912 return scm_i_print_array_dimension (&h
, 0, 0, port
, pstate
);
915 /* Read an array. This function can also read vectors and uniform
916 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
919 C is the first character read after the '#'.
923 tag_to_type (const char *tag
, SCM port
)
928 return scm_from_locale_symbol (tag
);
932 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
944 while ('0' <= c
&& c
<= '9')
946 res
= 10*res
+ c
-'0';
957 scm_i_read_array (SCM port
, int c
)
964 SCM shape
= SCM_BOOL_F
, elements
;
966 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
967 the array code can not deal with zero-length dimensions yet, and
968 we want to allow zero-length vectors, of course.
972 scm_ungetc (c
, port
);
973 return scm_vector (scm_read (port
));
976 /* Disambiguate between '#f' and uniform floating point vectors.
981 if (c
!= '3' && c
!= '6')
984 scm_ungetc (c
, port
);
991 goto continue_reading_tag
;
997 c
= read_decimal_integer (port
, c
, &rank
);
999 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
1005 continue_reading_tag
:
1006 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
1009 c
= scm_getc (port
);
1011 tag
[tag_len
] = '\0';
1015 if (c
== '@' || c
== ':')
1021 ssize_t lbnd
= 0, len
= 0;
1026 c
= scm_getc (port
);
1027 c
= read_decimal_integer (port
, c
, &lbnd
);
1030 s
= scm_from_ssize_t (lbnd
);
1034 c
= scm_getc (port
);
1035 c
= read_decimal_integer (port
, c
, &len
);
1037 scm_i_input_error (NULL
, port
,
1038 "array length must be non-negative",
1041 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
1044 shape
= scm_cons (s
, shape
);
1045 } while (c
== '@' || c
== ':');
1047 shape
= scm_reverse_x (shape
, SCM_EOL
);
1050 /* Read nested lists of elements.
1053 scm_i_input_error (NULL
, port
,
1054 "missing '(' in vector or array literal",
1056 scm_ungetc (c
, port
);
1057 elements
= scm_read (port
);
1059 if (scm_is_false (shape
))
1060 shape
= scm_from_ssize_t (rank
);
1061 else if (scm_ilength (shape
) != rank
)
1064 "the number of shape specifications must match the array rank",
1067 /* Handle special print syntax of rank zero arrays; see
1068 scm_i_print_array for a rationale.
1072 if (!scm_is_pair (elements
))
1073 scm_i_input_error (NULL
, port
,
1074 "too few elements in array literal, need 1",
1076 if (!scm_is_null (SCM_CDR (elements
)))
1077 scm_i_input_error (NULL
, port
,
1078 "too many elements in array literal, want 1",
1080 elements
= SCM_CAR (elements
);
1085 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
1090 array_mark (SCM ptr
)
1092 return SCM_I_ARRAY_V (ptr
);
1096 array_free (SCM ptr
)
1098 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
1099 (sizeof (scm_i_t_array
)
1100 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
1106 array_handle_ref (scm_t_array_handle
*h
, size_t pos
)
1108 return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h
->array
), pos
);
1112 array_handle_set (scm_t_array_handle
*h
, size_t pos
, SCM val
)
1114 scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
1117 /* FIXME: should be handle for vect? maybe not, because of dims */
1119 array_get_handle (SCM array
, scm_t_array_handle
*h
)
1121 scm_t_array_handle vh
;
1122 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
1123 h
->element_type
= vh
.element_type
;
1124 h
->elements
= vh
.elements
;
1125 h
->writable_elements
= vh
.writable_elements
;
1126 scm_array_handle_release (&vh
);
1128 h
->dims
= SCM_I_ARRAY_DIMS (array
);
1129 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
1130 h
->base
= SCM_I_ARRAY_BASE (array
);
1133 SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array
, 0xffff,
1134 array_handle_ref
, array_handle_set
,
1140 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
1141 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
1142 scm_set_smob_free (scm_i_tc16_array
, array_free
);
1143 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
1144 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
1146 scm_add_feature ("array");
1148 #include "libguile/arrays.x"