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"
48 #include "libguile/validate.h"
49 #include "libguile/arrays.h"
50 #include "libguile/generalized-arrays.h"
51 #include "libguile/generalized-vectors.h"
52 #include "libguile/uniform.h"
53 #include "libguile/array-map.h"
54 #include "libguile/print.h"
55 #include "libguile/read.h"
66 /* The set of uniform scm_vector types is:
67 * Vector of: Called: Replaced by:
68 * unsigned char string
69 * char byvect s8 or u8, depending on signedness of 'char'
71 * signed long ivect s32
72 * unsigned long uvect u32
75 * complex double cvect c64
77 * long long llvect s64
80 scm_t_bits scm_i_tc16_array
;
82 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
83 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
84 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
85 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 typedef SCM
creator_proc (SCM len
, SCM fill
);
92 creator_proc
*creator
;
93 } type_creator_table
[] = {
94 { "a", SCM_UNSPECIFIED
, scm_make_string
},
95 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
96 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
97 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
98 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
99 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
100 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
101 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
102 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
103 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
104 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
105 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
106 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
107 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
108 { "vu8", SCM_UNSPECIFIED
, scm_make_bytevector
},
113 init_type_creator_table ()
116 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
118 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
119 type_creator_table
[i
].type
= scm_permanent_object (sym
);
123 static creator_proc
*
124 type_to_creator (SCM type
)
128 if (scm_is_eq (type
, SCM_BOOL_T
))
129 return scm_make_vector
;
130 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
131 if (scm_is_eq (type
, type_creator_table
[i
].type
))
132 return type_creator_table
[i
].creator
;
134 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
138 make_typed_vector (SCM type
, size_t len
)
140 creator_proc
*creator
= type_to_creator (type
);
141 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
145 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
147 "Return the root vector of a shared array.")
148 #define FUNC_NAME s_scm_shared_array_root
150 if (SCM_I_ARRAYP (ra
))
151 return SCM_I_ARRAY_V (ra
);
152 else if (scm_is_generalized_vector (ra
))
154 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
159 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
161 "Return the root vector index of the first element in the array.")
162 #define FUNC_NAME s_scm_shared_array_offset
164 scm_t_array_handle handle
;
167 scm_array_get_handle (ra
, &handle
);
168 res
= scm_from_size_t (handle
.base
);
169 scm_array_handle_release (&handle
);
175 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
177 "For each dimension, return the distance between elements in the root vector.")
178 #define FUNC_NAME s_scm_shared_array_increments
180 scm_t_array_handle handle
;
185 scm_array_get_handle (ra
, &handle
);
186 k
= scm_array_handle_rank (&handle
);
187 s
= scm_array_handle_dims (&handle
);
189 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
190 scm_array_handle_release (&handle
);
196 scm_i_make_array (int ndim
)
199 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_i_tc16_array
,
200 scm_gc_malloc ((sizeof (scm_i_t_array
) +
201 ndim
* sizeof (scm_t_array_dim
)),
203 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
207 static char s_bad_spec
[] = "Bad scm_array dimension";
210 /* Increments will still need to be set. */
213 scm_i_shap2ra (SCM args
)
217 int ndim
= scm_ilength (args
);
219 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
221 ra
= scm_i_make_array (ndim
);
222 SCM_I_ARRAY_BASE (ra
) = 0;
223 s
= SCM_I_ARRAY_DIMS (ra
);
224 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
226 spec
= SCM_CAR (args
);
227 if (scm_is_integer (spec
))
229 if (scm_to_long (spec
) < 0)
230 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
232 s
->ubnd
= scm_to_long (spec
) - 1;
237 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
238 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
239 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
241 if (!scm_is_pair (sp
)
242 || !scm_is_integer (SCM_CAR (sp
))
243 || !scm_is_null (SCM_CDR (sp
)))
244 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
245 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
252 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
253 (SCM type
, SCM fill
, SCM bounds
),
254 "Create and return an array of type @var{type}.")
255 #define FUNC_NAME s_scm_make_typed_array
259 creator_proc
*creator
;
262 creator
= type_to_creator (type
);
263 ra
= scm_i_shap2ra (bounds
);
264 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
265 s
= SCM_I_ARRAY_DIMS (ra
);
266 k
= SCM_I_ARRAY_NDIM (ra
);
271 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
272 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
275 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
276 fill
= SCM_UNDEFINED
;
278 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
280 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
281 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
282 return SCM_I_ARRAY_V (ra
);
288 scm_from_contiguous_typed_array (SCM type
, SCM bounds
, const void *bytes
,
290 #define FUNC_NAME "scm_from_contiguous_typed_array"
294 creator_proc
*creator
;
296 scm_t_array_handle h
;
300 creator
= type_to_creator (type
);
301 ra
= scm_i_shap2ra (bounds
);
302 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
303 s
= SCM_I_ARRAY_DIMS (ra
);
304 k
= SCM_I_ARRAY_NDIM (ra
);
309 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
310 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
312 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), SCM_UNDEFINED
);
315 scm_array_get_handle (ra
, &h
);
316 base
= scm_array_handle_uniform_writable_elements (&h
);
317 sz
= scm_array_handle_uniform_element_size (&h
);
318 scm_array_handle_release (&h
);
321 SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL
);
322 if (byte_len
/ sz
!= rlen
)
323 SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL
);
325 memcpy (base
, bytes
, byte_len
);
327 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
328 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
329 return SCM_I_ARRAY_V (ra
);
334 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
335 (SCM fill
, SCM bounds
),
336 "Create and return an array.")
337 #define FUNC_NAME s_scm_make_array
339 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
344 scm_i_ra_set_contp (SCM ra
)
346 size_t k
= SCM_I_ARRAY_NDIM (ra
);
349 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
352 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
354 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
357 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
358 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
361 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
365 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
366 (SCM oldra
, SCM mapfunc
, SCM dims
),
367 "@code{make-shared-array} can be used to create shared subarrays of other\n"
368 "arrays. The @var{mapper} is a function that translates coordinates in\n"
369 "the new array into coordinates in the old array. A @var{mapper} must be\n"
370 "linear, and its range must stay within the bounds of the old array, but\n"
371 "it can be otherwise arbitrary. A simple example:\n"
373 "(define fred (make-array #f 8 8))\n"
374 "(define freds-diagonal\n"
375 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
376 "(array-set! freds-diagonal 'foo 3)\n"
377 "(array-ref fred 3 3) @result{} foo\n"
378 "(define freds-center\n"
379 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
380 "(array-ref freds-center 0 0) @result{} foo\n"
382 #define FUNC_NAME s_scm_make_shared_array
384 scm_t_array_handle old_handle
;
390 long old_base
, old_min
, new_min
, old_max
, new_max
;
393 SCM_VALIDATE_REST_ARGUMENT (dims
);
394 SCM_VALIDATE_PROC (2, mapfunc
);
395 ra
= scm_i_shap2ra (dims
);
397 scm_array_get_handle (oldra
, &old_handle
);
399 if (SCM_I_ARRAYP (oldra
))
401 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
402 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
403 s
= scm_array_handle_dims (&old_handle
);
404 k
= scm_array_handle_rank (&old_handle
);
408 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
410 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
415 SCM_I_ARRAY_V (ra
) = oldra
;
416 old_base
= old_min
= 0;
417 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
421 s
= SCM_I_ARRAY_DIMS (ra
);
422 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
424 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
425 if (s
[k
].ubnd
< s
[k
].lbnd
)
427 if (1 == SCM_I_ARRAY_NDIM (ra
))
428 ra
= make_typed_vector (scm_array_type (ra
), 0);
430 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
431 scm_array_handle_release (&old_handle
);
436 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
437 i
= scm_array_handle_pos (&old_handle
, imap
);
438 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
440 k
= SCM_I_ARRAY_NDIM (ra
);
443 if (s
[k
].ubnd
> s
[k
].lbnd
)
445 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
446 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
447 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
450 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
452 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
455 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
456 indptr
= SCM_CDR (indptr
);
459 scm_array_handle_release (&old_handle
);
461 if (old_min
> new_min
|| old_max
< new_max
)
462 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
463 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
465 SCM v
= SCM_I_ARRAY_V (ra
);
466 size_t length
= scm_c_generalized_vector_length (v
);
467 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
469 if (s
->ubnd
< s
->lbnd
)
470 return make_typed_vector (scm_array_type (ra
), 0);
472 scm_i_ra_set_contp (ra
);
478 /* args are RA . DIMS */
479 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
481 "Return an array sharing contents with @var{array}, but with\n"
482 "dimensions arranged in a different order. There must be one\n"
483 "@var{dim} argument for each dimension of @var{array}.\n"
484 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
485 "and the rank of the array to be returned. Each integer in that\n"
486 "range must appear at least once in the argument list.\n"
488 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
489 "dimensions in the array to be returned, their positions in the\n"
490 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
491 "may have the same value, in which case the returned array will\n"
492 "have smaller rank than @var{array}.\n"
495 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
496 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
497 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
498 " #2((a 4) (b 5) (c 6))\n"
500 #define FUNC_NAME s_scm_transpose_array
503 scm_t_array_dim
*s
, *r
;
506 SCM_VALIDATE_REST_ARGUMENT (args
);
507 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
509 if (scm_is_generalized_vector (ra
))
511 /* Make sure that we are called with a single zero as
514 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
515 SCM_WRONG_NUM_ARGS ();
516 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
517 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
521 if (SCM_I_ARRAYP (ra
))
523 vargs
= scm_vector (args
);
524 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
525 SCM_WRONG_NUM_ARGS ();
527 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
529 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
530 0, SCM_I_ARRAY_NDIM(ra
));
535 res
= scm_i_make_array (ndim
);
536 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
537 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
540 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
541 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
543 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
545 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
546 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
547 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
548 if (r
->ubnd
< r
->lbnd
)
557 if (r
->ubnd
> s
->ubnd
)
559 if (r
->lbnd
< s
->lbnd
)
561 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
568 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
569 scm_i_ra_set_contp (res
);
573 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
577 /* attempts to unroll an array into a one-dimensional array.
578 returns the unrolled array or #f if it can't be done. */
579 /* if strict is not SCM_UNDEFINED, return #f if returned array
580 wouldn't have contiguous elements. */
581 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
582 (SCM ra
, SCM strict
),
583 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
584 "without changing their order (last subscript changing fastest), then\n"
585 "@code{array-contents} returns that shared array, otherwise it returns\n"
586 "@code{#f}. All arrays made by @var{make-array} and\n"
587 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
588 "@var{make-shared-array} may not be.\n\n"
589 "If the optional argument @var{strict} is provided, a shared array will\n"
590 "be returned only if its elements are stored internally contiguous in\n"
592 #define FUNC_NAME s_scm_array_contents
596 if (scm_is_generalized_vector (ra
))
599 if (SCM_I_ARRAYP (ra
))
601 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
602 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
604 for (k
= 0; k
< ndim
; k
++)
605 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
606 if (!SCM_UNBNDP (strict
))
608 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
610 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
612 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
613 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
620 SCM v
= SCM_I_ARRAY_V (ra
);
621 size_t length
= scm_c_generalized_vector_length (v
);
622 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
626 sra
= scm_i_make_array (1);
627 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
628 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
629 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
630 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
631 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
635 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
641 scm_ra2contig (SCM ra
, int copy
)
646 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
647 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
648 k
= SCM_I_ARRAY_NDIM (ra
);
649 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
651 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
653 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
654 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
655 0 == len
% SCM_LONG_BIT
))
658 ret
= scm_i_make_array (k
);
659 SCM_I_ARRAY_BASE (ret
) = 0;
662 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
663 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
664 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
665 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
667 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
669 scm_array_copy_x (ra
, ret
);
675 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
676 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
677 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
678 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
679 "binary objects from @var{port-or-fdes}.\n"
680 "If an end of file is encountered,\n"
681 "the objects up to that point are put into @var{ura}\n"
682 "(starting at the beginning) and the remainder of the array is\n"
684 "The optional arguments @var{start} and @var{end} allow\n"
685 "a specified region of a vector (or linearized array) to be read,\n"
686 "leaving the remainder of the vector unchanged.\n\n"
687 "@code{uniform-array-read!} returns the number of objects read.\n"
688 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
689 "returned by @code{(current-input-port)}.")
690 #define FUNC_NAME s_scm_uniform_array_read_x
692 if (SCM_UNBNDP (port_or_fd
))
693 port_or_fd
= scm_current_input_port ();
695 if (scm_is_uniform_vector (ura
))
697 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
699 else if (SCM_I_ARRAYP (ura
))
701 size_t base
, vlen
, cstart
, cend
;
704 cra
= scm_ra2contig (ura
, 0);
705 base
= SCM_I_ARRAY_BASE (cra
);
706 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
707 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
711 if (!SCM_UNBNDP (start
))
713 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
714 if (!SCM_UNBNDP (end
))
715 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
718 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
719 scm_from_size_t (base
+ cstart
),
720 scm_from_size_t (base
+ cend
));
722 if (!scm_is_eq (cra
, ura
))
723 scm_array_copy_x (cra
, ura
);
727 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
731 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
732 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
733 "Writes all elements of @var{ura} as binary objects to\n"
734 "@var{port-or-fdes}.\n\n"
735 "The optional arguments @var{start}\n"
736 "and @var{end} allow\n"
737 "a specified region of a vector (or linearized array) to be written.\n\n"
738 "The number of objects actually written is returned.\n"
739 "@var{port-or-fdes} may be\n"
740 "omitted, in which case it defaults to the value returned by\n"
741 "@code{(current-output-port)}.")
742 #define FUNC_NAME s_scm_uniform_array_write
744 if (SCM_UNBNDP (port_or_fd
))
745 port_or_fd
= scm_current_output_port ();
747 if (scm_is_uniform_vector (ura
))
749 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
751 else if (SCM_I_ARRAYP (ura
))
753 size_t base
, vlen
, cstart
, cend
;
756 cra
= scm_ra2contig (ura
, 1);
757 base
= SCM_I_ARRAY_BASE (cra
);
758 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
759 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
763 if (!SCM_UNBNDP (start
))
765 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
766 if (!SCM_UNBNDP (end
))
767 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
770 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
771 scm_from_size_t (base
+ cstart
),
772 scm_from_size_t (base
+ cend
));
777 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
782 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
784 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
785 (SCM type
, SCM shape
, SCM lst
),
786 "Return an array of the type @var{type}\n"
787 "with elements the same as those of @var{lst}.\n"
789 "The argument @var{shape} determines the number of dimensions\n"
790 "of the array and their shape. It is either an exact integer,\n"
792 "number of dimensions directly, or a list whose length\n"
793 "specifies the number of dimensions and each element specified\n"
794 "the lower and optionally the upper bound of the corresponding\n"
796 "When the element is list of two elements, these elements\n"
797 "give the lower and upper bounds. When it is an exact\n"
798 "integer, it gives only the lower bound.")
799 #define FUNC_NAME s_scm_list_to_typed_array
803 scm_t_array_handle handle
;
806 if (scm_is_integer (shape
))
808 size_t k
= scm_to_size_t (shape
);
812 shape
= scm_cons (scm_length (row
), shape
);
813 if (k
> 0 && !scm_is_null (row
))
819 SCM shape_spec
= shape
;
823 SCM spec
= scm_car (shape_spec
);
824 if (scm_is_pair (spec
))
825 shape
= scm_cons (spec
, shape
);
827 shape
= scm_cons (scm_list_2 (spec
,
828 scm_sum (scm_sum (spec
,
832 shape_spec
= scm_cdr (shape_spec
);
833 if (scm_is_pair (shape_spec
))
835 if (!scm_is_null (row
))
843 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
844 scm_reverse_x (shape
, SCM_EOL
));
846 scm_array_get_handle (ra
, &handle
);
847 l2ra (lst
, &handle
, 0, 0);
848 scm_array_handle_release (&handle
);
854 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
856 "Return an array with elements the same as those of @var{lst}.")
857 #define FUNC_NAME s_scm_list_to_array
859 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
864 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
866 if (k
== scm_array_handle_rank (handle
))
867 scm_array_handle_set (handle
, pos
, lst
);
870 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
871 ssize_t inc
= dim
->inc
;
872 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
876 while (n
> 0 && scm_is_pair (lst
))
878 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
884 errmsg
= "too few elements for array dimension ~a, need ~a";
885 if (!scm_is_null (lst
))
886 errmsg
= "too many elements for array dimension ~a, want ~a";
888 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
889 scm_from_size_t (len
)));
893 /* Print dimension DIM of ARRAY.
897 scm_i_print_array_dimension (SCM array
, int dim
, int base
,
898 SCM port
, scm_print_state
*pstate
)
900 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
903 scm_putc ('(', port
);
905 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
907 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
908 scm_i_print_array_dimension (array
, dim
+1, base
,
911 scm_iprin1 (scm_c_generalized_vector_ref (SCM_I_ARRAY_V (array
), base
),
913 if (idx
< dim_spec
->ubnd
)
914 scm_putc (' ', port
);
915 base
+= dim_spec
->inc
;
918 scm_putc (')', port
);
922 /* Print an array. (Only for strict arrays, not for generalized vectors.)
926 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
928 long ndim
= SCM_I_ARRAY_NDIM (array
);
929 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
930 SCM v
= SCM_I_ARRAY_V (array
);
931 unsigned long base
= SCM_I_ARRAY_BASE (array
);
933 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
935 scm_putc ('#', port
);
936 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
937 scm_intprint (ndim
, 10, port
);
938 if (scm_is_uniform_vector (v
))
939 scm_puts (scm_i_uniform_vector_tag (v
), port
);
940 else if (scm_is_bitvector (v
))
941 scm_puts ("b", port
);
942 else if (scm_is_string (v
))
943 scm_puts ("a", port
);
944 else if (!scm_is_vector (v
))
945 scm_puts ("?", port
);
947 for (i
= 0; i
< ndim
; i
++)
949 if (dim_specs
[i
].lbnd
!= 0)
951 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
957 if (print_lbnds
|| print_lens
)
958 for (i
= 0; i
< ndim
; i
++)
962 scm_putc ('@', port
);
963 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
967 scm_putc (':', port
);
968 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
975 /* Rank zero arrays, which are really just scalars, are printed
976 specially. The consequent way would be to print them as
980 where OBJ is the printed representation of the scalar, but we
981 print them instead as
985 to make them look less strange.
987 Just printing them as
991 would be correct in a way as well, but zero rank arrays are
992 not really the same as Scheme values since they are boxed and
993 can be modified with array-set!, say.
995 scm_putc ('(', port
);
996 scm_iprin1 (scm_c_generalized_vector_ref (v
, base
), port
, pstate
);
997 scm_putc (')', port
);
1001 return scm_i_print_array_dimension (array
, 0, base
, port
, pstate
);
1004 /* Read an array. This function can also read vectors and uniform
1005 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
1008 C is the first character read after the '#'.
1012 tag_to_type (const char *tag
, SCM port
)
1017 return scm_from_locale_symbol (tag
);
1021 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
1030 c
= scm_getc (port
);
1033 while ('0' <= c
&& c
<= '9')
1035 res
= 10*res
+ c
-'0';
1037 c
= scm_getc (port
);
1046 scm_i_read_array (SCM port
, int c
)
1053 SCM shape
= SCM_BOOL_F
, elements
;
1055 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
1056 the array code can not deal with zero-length dimensions yet, and
1057 we want to allow zero-length vectors, of course.
1061 scm_ungetc (c
, port
);
1062 return scm_vector (scm_read (port
));
1065 /* Disambiguate between '#f' and uniform floating point vectors.
1069 c
= scm_getc (port
);
1070 if (c
!= '3' && c
!= '6')
1073 scm_ungetc (c
, port
);
1080 goto continue_reading_tag
;
1086 c
= read_decimal_integer (port
, c
, &rank
);
1088 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
1094 continue_reading_tag
:
1095 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
1098 c
= scm_getc (port
);
1100 tag
[tag_len
] = '\0';
1104 if (c
== '@' || c
== ':')
1110 ssize_t lbnd
= 0, len
= 0;
1115 c
= scm_getc (port
);
1116 c
= read_decimal_integer (port
, c
, &lbnd
);
1119 s
= scm_from_ssize_t (lbnd
);
1123 c
= scm_getc (port
);
1124 c
= read_decimal_integer (port
, c
, &len
);
1126 scm_i_input_error (NULL
, port
,
1127 "array length must be non-negative",
1130 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
1133 shape
= scm_cons (s
, shape
);
1134 } while (c
== '@' || c
== ':');
1136 shape
= scm_reverse_x (shape
, SCM_EOL
);
1139 /* Read nested lists of elements.
1142 scm_i_input_error (NULL
, port
,
1143 "missing '(' in vector or array literal",
1145 scm_ungetc (c
, port
);
1146 elements
= scm_read (port
);
1148 if (scm_is_false (shape
))
1149 shape
= scm_from_ssize_t (rank
);
1150 else if (scm_ilength (shape
) != rank
)
1153 "the number of shape specifications must match the array rank",
1156 /* Handle special print syntax of rank zero arrays; see
1157 scm_i_print_array for a rationale.
1161 if (!scm_is_pair (elements
))
1162 scm_i_input_error (NULL
, port
,
1163 "too few elements in array literal, need 1",
1165 if (!scm_is_null (SCM_CDR (elements
)))
1166 scm_i_input_error (NULL
, port
,
1167 "too many elements in array literal, want 1",
1169 elements
= SCM_CAR (elements
);
1174 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
1179 array_mark (SCM ptr
)
1181 return SCM_I_ARRAY_V (ptr
);
1185 array_free (SCM ptr
)
1187 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
1188 (sizeof (scm_i_t_array
)
1189 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
1195 array_handle_ref (scm_t_array_handle
*h
, size_t pos
)
1197 return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h
->array
), pos
);
1201 array_handle_set (scm_t_array_handle
*h
, size_t pos
, SCM val
)
1203 scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
1206 /* FIXME: should be handle for vect? maybe not, because of dims */
1208 array_get_handle (SCM array
, scm_t_array_handle
*h
)
1210 scm_t_array_handle vh
;
1211 scm_array_get_handle (SCM_I_ARRAY_V (array
), &vh
);
1212 h
->element_type
= vh
.element_type
;
1213 h
->elements
= vh
.elements
;
1214 h
->writable_elements
= vh
.writable_elements
;
1215 scm_array_handle_release (&vh
);
1217 h
->dims
= SCM_I_ARRAY_DIMS (array
);
1218 h
->ndims
= SCM_I_ARRAY_NDIM (array
);
1219 h
->base
= SCM_I_ARRAY_BASE (array
);
1222 SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array
, 0xffff,
1223 array_handle_ref
, array_handle_set
,
1229 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
1230 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
1231 scm_set_smob_free (scm_i_tc16_array
, array_free
);
1232 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
1233 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
1235 scm_add_feature ("array");
1237 init_type_creator_table ();
1239 #include "libguile/arrays.x"