1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_i_tc16_array;
83 scm_t_bits scm_i_tc16_enclosed_array;
85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
86 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
88 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
90 typedef SCM creator_proc (SCM len, SCM fill);
95 creator_proc *creator;
96 } type_creator_table[] = {
97 { "a", SCM_UNSPECIFIED, scm_make_string },
98 { "b", SCM_UNSPECIFIED, scm_make_bitvector },
99 { "u8", SCM_UNSPECIFIED, scm_make_u8vector },
100 { "s8", SCM_UNSPECIFIED, scm_make_s8vector },
101 { "u16", SCM_UNSPECIFIED, scm_make_u16vector },
102 { "s16", SCM_UNSPECIFIED, scm_make_s16vector },
103 { "u32", SCM_UNSPECIFIED, scm_make_u32vector },
104 { "s32", SCM_UNSPECIFIED, scm_make_s32vector },
105 { "u64", SCM_UNSPECIFIED, scm_make_u64vector },
106 { "s64", SCM_UNSPECIFIED, scm_make_s64vector },
107 { "f32", SCM_UNSPECIFIED, scm_make_f32vector },
108 { "f64", SCM_UNSPECIFIED, scm_make_f64vector },
109 { "c32", SCM_UNSPECIFIED, scm_make_c32vector },
110 { "c64", SCM_UNSPECIFIED, scm_make_c64vector },
115 init_type_creator_table ()
118 for (i = 0; type_creator_table[i].type_name; i++)
120 SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name);
121 type_creator_table[i].type = scm_permanent_object (sym);
125 static creator_proc *
126 type_to_creator (SCM type)
130 if (scm_is_eq (type, SCM_BOOL_T))
131 return scm_make_vector;
132 for (i = 0; type_creator_table[i].type_name; i++)
133 if (scm_is_eq (type, type_creator_table[i].type))
134 return type_creator_table[i].creator;
136 scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type));
140 make_typed_vector (SCM type, size_t len)
142 creator_proc *creator = type_to_creator (type);
143 return creator (scm_from_size_t (len), SCM_UNDEFINED);
146 #if SCM_ENABLE_DEPRECATED
148 SCM_SYMBOL (scm_sym_s, "s");
149 SCM_SYMBOL (scm_sym_l, "l");
154 if (!SCM_REALP (obj))
158 double x = SCM_REAL_VALUE (obj);
160 return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
164 SCM_API int scm_i_inump (SCM obj);
165 SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
168 prototype_to_type (SCM proto)
170 const char *type_name;
172 if (scm_is_eq (proto, SCM_BOOL_T))
174 else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
176 else if (SCM_CHARP (proto))
178 else if (scm_i_inump (proto))
180 if (scm_i_inum (proto) > 0)
185 else if (scm_is_eq (proto, scm_sym_s))
187 else if (scm_is_eq (proto, scm_sym_l))
189 else if (SCM_REALP (proto)
190 || scm_is_true (scm_eqv_p (proto,
191 scm_divide (scm_from_int (1),
199 else if (SCM_COMPLEXP (proto))
201 else if (scm_is_null (proto))
207 return scm_from_locale_symbol (type_name);
213 scm_i_get_old_prototype (SCM uvec)
215 if (scm_is_bitvector (uvec))
217 else if (scm_is_string (uvec))
218 return SCM_MAKE_CHAR ('a');
219 else if (scm_is_true (scm_s8vector_p (uvec)))
220 return SCM_MAKE_CHAR ('\0');
221 else if (scm_is_true (scm_s16vector_p (uvec)))
223 else if (scm_is_true (scm_u32vector_p (uvec)))
224 return scm_from_int (1);
225 else if (scm_is_true (scm_s32vector_p (uvec)))
226 return scm_from_int (-1);
227 else if (scm_is_true (scm_s64vector_p (uvec)))
229 else if (scm_is_true (scm_f32vector_p (uvec)))
230 return scm_from_double (1.0);
231 else if (scm_is_true (scm_f64vector_p (uvec)))
232 return scm_divide (scm_from_int (1), scm_from_int (3));
233 else if (scm_is_true (scm_c64vector_p (uvec)))
234 return scm_c_make_rectangular (0, 1);
235 else if (scm_is_vector (uvec))
238 scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec));
242 scm_make_uve (long k, SCM prot)
243 #define FUNC_NAME "scm_make_uve"
245 scm_c_issue_deprecation_warning
246 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
248 return make_typed_vector (prototype_to_type (prot), k);
255 scm_is_array (SCM obj)
257 return (SCM_I_ENCLOSED_ARRAYP (obj)
258 || SCM_I_ARRAYP (obj)
259 || scm_is_generalized_vector (obj));
263 scm_is_typed_array (SCM obj, SCM type)
265 if (SCM_I_ENCLOSED_ARRAYP (obj))
267 /* Enclosed arrays are arrays but are not of any type.
272 /* Get storage vector.
274 if (SCM_I_ARRAYP (obj))
275 obj = SCM_I_ARRAY_V (obj);
277 /* It must be a generalized vector (which includes vectors, strings, etc).
279 if (!scm_is_generalized_vector (obj))
282 return scm_is_eq (type, scm_i_generalized_vector_type (obj));
286 enclosed_ref (scm_t_array_handle *h, ssize_t pos)
288 return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
292 vector_ref (scm_t_array_handle *h, ssize_t pos)
294 return ((const SCM *)h->elements)[pos];
298 string_ref (scm_t_array_handle *h, ssize_t pos)
301 if (SCM_I_ARRAYP (h->array))
302 return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
304 return scm_c_string_ref (h->array, pos);
308 bitvector_ref (scm_t_array_handle *h, ssize_t pos)
310 pos += scm_array_handle_bit_elements_offset (h);
312 scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
316 memoize_ref (scm_t_array_handle *h, ssize_t pos)
320 if (SCM_I_ENCLOSED_ARRAYP (v))
322 h->ref = enclosed_ref;
323 return enclosed_ref (h, pos);
326 if (SCM_I_ARRAYP (v))
327 v = SCM_I_ARRAY_V (v);
329 if (scm_is_vector (v))
331 h->elements = scm_array_handle_elements (h);
334 else if (scm_is_uniform_vector (v))
336 h->elements = scm_array_handle_uniform_elements (h);
337 h->ref = scm_i_uniform_vector_ref_proc (v);
339 else if (scm_is_string (v))
343 else if (scm_is_bitvector (v))
345 h->elements = scm_array_handle_bit_elements (h);
346 h->ref = bitvector_ref;
349 scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
351 return h->ref (h, pos);
355 enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
357 scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
361 vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
363 ((SCM *)h->writable_elements)[pos] = val;
367 string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
370 if (SCM_I_ARRAYP (h->array))
371 scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
373 scm_c_string_set_x (h->array, pos, val);
377 bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
380 pos += scm_array_handle_bit_elements_offset (h);
381 mask = 1l << (pos % 32);
382 if (scm_to_bool (val))
383 ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
385 ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
389 memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
393 if (SCM_I_ENCLOSED_ARRAYP (v))
395 h->set = enclosed_set;
396 enclosed_set (h, pos, val);
400 if (SCM_I_ARRAYP (v))
401 v = SCM_I_ARRAY_V (v);
403 if (scm_is_vector (v))
405 h->writable_elements = scm_array_handle_writable_elements (h);
408 else if (scm_is_uniform_vector (v))
410 h->writable_elements = scm_array_handle_uniform_writable_elements (h);
411 h->set = scm_i_uniform_vector_set_proc (v);
413 else if (scm_is_string (v))
417 else if (scm_is_bitvector (v))
419 h->writable_elements = scm_array_handle_bit_writable_elements (h);
420 h->set = bitvector_set;
423 scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
425 h->set (h, pos, val);
429 scm_array_get_handle (SCM array, scm_t_array_handle *h)
432 h->ref = memoize_ref;
433 h->set = memoize_set;
435 if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
437 h->dims = SCM_I_ARRAY_DIMS (array);
438 h->base = SCM_I_ARRAY_BASE (array);
440 else if (scm_is_generalized_vector (array))
443 h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
449 scm_wrong_type_arg_msg (NULL, 0, array, "array");
453 scm_array_handle_release (scm_t_array_handle *h)
455 /* Nothing to do here until arrays need to be reserved for real.
460 scm_array_handle_rank (scm_t_array_handle *h)
462 if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
463 return SCM_I_ARRAY_NDIM (h->array);
469 scm_array_handle_dims (scm_t_array_handle *h)
475 scm_array_handle_elements (scm_t_array_handle *h)
478 if (SCM_I_ARRAYP (vec))
479 vec = SCM_I_ARRAY_V (vec);
480 if (SCM_I_IS_VECTOR (vec))
481 return SCM_I_VECTOR_ELTS (vec) + h->base;
482 scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
486 scm_array_handle_writable_elements (scm_t_array_handle *h)
489 if (SCM_I_ARRAYP (vec))
490 vec = SCM_I_ARRAY_V (vec);
491 if (SCM_I_IS_VECTOR (vec))
492 return SCM_I_VECTOR_WELTS (vec) + h->base;
493 scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
496 #if SCM_ENABLE_DEPRECATED
498 SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
500 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
502 #define FUNC_NAME s_scm_array_p
504 if (!SCM_UNBNDP (prot))
506 scm_c_issue_deprecation_warning
507 ("Using prototypes with `array?' is deprecated."
508 " Use `typed-array?' instead.");
510 return scm_typed_array_p (obj, prototype_to_type (prot));
513 return scm_from_bool (scm_is_array (obj));
517 #else /* !SCM_ENABLE_DEPRECATED */
519 /* We keep the old 2-argument C prototype for a while although the old
520 PROT argument is always ignored now. C code should probably use
521 scm_is_array or scm_is_typed_array anyway.
524 static SCM scm_i_array_p (SCM obj);
526 SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0,
528 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
530 #define FUNC_NAME s_scm_i_array_p
532 return scm_from_bool (scm_is_array (obj));
537 scm_array_p (SCM obj, SCM prot)
539 return scm_from_bool (scm_is_array (obj));
542 #endif /* !SCM_ENABLE_DEPRECATED */
545 SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
547 "Return @code{#t} if the @var{obj} is an array of type\n"
548 "@var{type}, and @code{#f} if not.")
549 #define FUNC_NAME s_scm_typed_array_p
551 return scm_from_bool (scm_is_typed_array (obj, type));
556 scm_c_array_rank (SCM array)
558 scm_t_array_handle handle;
561 scm_array_get_handle (array, &handle);
562 res = scm_array_handle_rank (&handle);
563 scm_array_handle_release (&handle);
567 SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
569 "Return the number of dimensions of the array @var{array.}\n")
570 #define FUNC_NAME s_scm_array_rank
572 return scm_from_size_t (scm_c_array_rank (array));
577 SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
579 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
580 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
582 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
584 #define FUNC_NAME s_scm_array_dimensions
586 scm_t_array_handle handle;
591 scm_array_get_handle (ra, &handle);
592 s = scm_array_handle_dims (&handle);
593 k = scm_array_handle_rank (&handle);
596 res = scm_cons (s[k].lbnd
597 ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
598 scm_from_ssize_t (s[k].ubnd),
600 : scm_from_ssize_t (1 + s[k].ubnd),
603 scm_array_handle_release (&handle);
609 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
611 "Return the root vector of a shared array.")
612 #define FUNC_NAME s_scm_shared_array_root
614 if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
615 return SCM_I_ARRAY_V (ra);
616 else if (scm_is_generalized_vector (ra))
618 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
623 SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
625 "Return the root vector index of the first element in the array.")
626 #define FUNC_NAME s_scm_shared_array_offset
628 scm_t_array_handle handle;
631 scm_array_get_handle (ra, &handle);
632 res = scm_from_size_t (handle.base);
633 scm_array_handle_release (&handle);
639 SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
641 "For each dimension, return the distance between elements in the root vector.")
642 #define FUNC_NAME s_scm_shared_array_increments
644 scm_t_array_handle handle;
649 scm_array_get_handle (ra, &handle);
650 k = scm_array_handle_rank (&handle);
651 s = scm_array_handle_dims (&handle);
653 res = scm_cons (scm_from_ssize_t (s[k].inc), res);
654 scm_array_handle_release (&handle);
660 scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
662 scm_t_array_dim *s = scm_array_handle_dims (h);
664 size_t k = scm_array_handle_rank (h);
666 while (k > 0 && scm_is_pair (indices))
668 i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
669 pos += (i - s->lbnd) * s->inc;
672 indices = SCM_CDR (indices);
674 if (k > 0 || !scm_is_null (indices))
675 scm_misc_error (NULL, "wrong number of indices, expecting ~a",
676 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
681 scm_i_make_ra (int ndim, int enclosed)
683 scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array;
685 SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
686 scm_gc_malloc ((sizeof (scm_i_t_array) +
687 ndim * sizeof (scm_t_array_dim)),
689 SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
693 static char s_bad_spec[] = "Bad scm_array dimension";
696 /* Increments will still need to be set. */
699 scm_i_shap2ra (SCM args)
703 int ndim = scm_ilength (args);
705 scm_misc_error (NULL, s_bad_spec, SCM_EOL);
707 ra = scm_i_make_ra (ndim, 0);
708 SCM_I_ARRAY_BASE (ra) = 0;
709 s = SCM_I_ARRAY_DIMS (ra);
710 for (; !scm_is_null (args); s++, args = SCM_CDR (args))
712 spec = SCM_CAR (args);
713 if (scm_is_integer (spec))
715 if (scm_to_long (spec) < 0)
716 scm_misc_error (NULL, s_bad_spec, SCM_EOL);
718 s->ubnd = scm_to_long (spec) - 1;
723 if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
724 scm_misc_error (NULL, s_bad_spec, SCM_EOL);
725 s->lbnd = scm_to_long (SCM_CAR (spec));
727 if (!scm_is_pair (sp)
728 || !scm_is_integer (SCM_CAR (sp))
729 || !scm_is_null (SCM_CDR (sp)))
730 scm_misc_error (NULL, s_bad_spec, SCM_EOL);
731 s->ubnd = scm_to_long (SCM_CAR (sp));
738 SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
739 (SCM type, SCM fill, SCM bounds),
740 "Create and return an array of type @var{type}.")
741 #define FUNC_NAME s_scm_make_typed_array
745 creator_proc *creator;
748 creator = type_to_creator (type);
749 ra = scm_i_shap2ra (bounds);
750 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
751 s = SCM_I_ARRAY_DIMS (ra);
752 k = SCM_I_ARRAY_NDIM (ra);
757 SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
758 rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
761 if (scm_is_eq (fill, SCM_UNSPECIFIED))
762 fill = SCM_UNDEFINED;
764 SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
766 if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
767 if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
768 return SCM_I_ARRAY_V (ra);
773 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
774 (SCM fill, SCM bounds),
775 "Create and return an array.")
776 #define FUNC_NAME s_scm_make_array
778 return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
782 #if SCM_ENABLE_DEPRECATED
784 SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
785 (SCM dims, SCM prot, SCM fill),
786 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
787 "Create and return a uniform array or vector of type\n"
788 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
789 "length @var{length}. If @var{fill} is supplied, it's used to\n"
790 "fill the array, otherwise @var{prototype} is used.")
791 #define FUNC_NAME s_scm_dimensions_to_uniform_array
793 scm_c_issue_deprecation_warning
794 ("`dimensions->uniform-array' is deprecated. "
795 "Use `make-typed-array' instead.");
797 if (scm_is_integer (dims))
798 dims = scm_list_1 (dims);
800 if (SCM_UNBNDP (fill))
802 /* Using #\nul as the prototype yields a s8 array, but numeric
803 arrays can't store characters, so we have to special case this.
805 if (scm_is_eq (prot, SCM_MAKE_CHAR (0)))
806 fill = scm_from_int (0);
811 return scm_make_typed_array (prototype_to_type (prot), fill, dims);
818 scm_i_ra_set_contp (SCM ra)
820 size_t k = SCM_I_ARRAY_NDIM (ra);
823 long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
826 if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
828 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
831 inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
832 - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
835 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
839 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
840 (SCM oldra, SCM mapfunc, SCM dims),
841 "@code{make-shared-array} can be used to create shared subarrays of other\n"
842 "arrays. The @var{mapper} is a function that translates coordinates in\n"
843 "the new array into coordinates in the old array. A @var{mapper} must be\n"
844 "linear, and its range must stay within the bounds of the old array, but\n"
845 "it can be otherwise arbitrary. A simple example:\n"
847 "(define fred (make-array #f 8 8))\n"
848 "(define freds-diagonal\n"
849 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
850 "(array-set! freds-diagonal 'foo 3)\n"
851 "(array-ref fred 3 3) @result{} foo\n"
852 "(define freds-center\n"
853 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
854 "(array-ref freds-center 0 0) @result{} foo\n"
856 #define FUNC_NAME s_scm_make_shared_array
858 scm_t_array_handle old_handle;
864 long old_base, old_min, new_min, old_max, new_max;
867 SCM_VALIDATE_REST_ARGUMENT (dims);
868 SCM_VALIDATE_PROC (2, mapfunc);
869 ra = scm_i_shap2ra (dims);
871 scm_array_get_handle (oldra, &old_handle);
873 if (SCM_I_ARRAYP (oldra))
875 SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
876 old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
877 s = scm_array_handle_dims (&old_handle);
878 k = scm_array_handle_rank (&old_handle);
882 old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
884 old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
889 SCM_I_ARRAY_V (ra) = oldra;
890 old_base = old_min = 0;
891 old_max = scm_c_generalized_vector_length (oldra) - 1;
895 s = SCM_I_ARRAY_DIMS (ra);
896 for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
898 inds = scm_cons (scm_from_long (s[k].lbnd), inds);
899 if (s[k].ubnd < s[k].lbnd)
901 if (1 == SCM_I_ARRAY_NDIM (ra))
902 ra = make_typed_vector (scm_array_type (ra), 0);
904 SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
905 scm_array_handle_release (&old_handle);
910 imap = scm_apply_0 (mapfunc, scm_reverse (inds));
911 i = scm_array_handle_pos (&old_handle, imap);
912 SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
914 k = SCM_I_ARRAY_NDIM (ra);
917 if (s[k].ubnd > s[k].lbnd)
919 SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
920 imap = scm_apply_0 (mapfunc, scm_reverse (inds));
921 s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
924 new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
926 new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
929 s[k].inc = new_max - new_min + 1; /* contiguous by default */
930 indptr = SCM_CDR (indptr);
933 scm_array_handle_release (&old_handle);
935 if (old_min > new_min || old_max < new_max)
936 SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
937 if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
939 SCM v = SCM_I_ARRAY_V (ra);
940 size_t length = scm_c_generalized_vector_length (v);
941 if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
943 if (s->ubnd < s->lbnd)
944 return make_typed_vector (scm_array_type (ra), 0);
946 scm_i_ra_set_contp (ra);
952 /* args are RA . DIMS */
953 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
955 "Return an array sharing contents with @var{array}, but with\n"
956 "dimensions arranged in a different order. There must be one\n"
957 "@var{dim} argument for each dimension of @var{array}.\n"
958 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
959 "and the rank of the array to be returned. Each integer in that\n"
960 "range must appear at least once in the argument list.\n"
962 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
963 "dimensions in the array to be returned, their positions in the\n"
964 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
965 "may have the same value, in which case the returned array will\n"
966 "have smaller rank than @var{array}.\n"
969 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
970 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
971 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
972 " #2((a 4) (b 5) (c 6))\n"
974 #define FUNC_NAME s_scm_transpose_array
977 scm_t_array_dim *s, *r;
980 SCM_VALIDATE_REST_ARGUMENT (args);
981 SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
983 if (scm_is_generalized_vector (ra))
985 /* Make sure that we are called with a single zero as
988 if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
989 SCM_WRONG_NUM_ARGS ();
990 SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
991 SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
995 if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
997 vargs = scm_vector (args);
998 if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
999 SCM_WRONG_NUM_ARGS ();
1001 for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
1003 i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
1004 0, SCM_I_ARRAY_NDIM(ra));
1009 res = scm_i_make_ra (ndim, 0);
1010 SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
1011 SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
1012 for (k = ndim; k--;)
1014 SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
1015 SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
1017 for (k = SCM_I_ARRAY_NDIM (ra); k--;)
1019 i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
1020 s = &(SCM_I_ARRAY_DIMS (ra)[k]);
1021 r = &(SCM_I_ARRAY_DIMS (res)[i]);
1022 if (r->ubnd < r->lbnd)
1031 if (r->ubnd > s->ubnd)
1033 if (r->lbnd < s->lbnd)
1035 SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
1042 SCM_MISC_ERROR ("bad argument list", SCM_EOL);
1043 scm_i_ra_set_contp (res);
1047 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1051 /* args are RA . AXES */
1052 SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
1054 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1055 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1056 "resembling an array of shared arrays. The dimensions of each shared\n"
1057 "array are the same as the @var{dim}th dimensions of the original array,\n"
1058 "the dimensions of the outer array are the same as those of the original\n"
1059 "array that did not match a @var{dim}.\n\n"
1060 "An enclosed array is not a general Scheme array. Its elements may not\n"
1061 "be set using @code{array-set!}. Two references to the same element of\n"
1062 "an enclosed array will be @code{equal?} but will not in general be\n"
1063 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1064 "enclosed array is unspecified.\n\n"
1067 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1068 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1069 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1070 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1072 #define FUNC_NAME s_scm_enclose_array
1074 SCM axv, res, ra_inr;
1076 scm_t_array_dim vdim, *s = &vdim;
1077 int ndim, j, k, ninr, noutr;
1079 SCM_VALIDATE_REST_ARGUMENT (axes);
1080 if (scm_is_null (axes))
1081 axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
1082 ninr = scm_ilength (axes);
1084 SCM_WRONG_NUM_ARGS ();
1085 ra_inr = scm_i_make_ra (ninr, 0);
1087 if (scm_is_generalized_vector (ra))
1090 s->ubnd = scm_c_generalized_vector_length (ra) - 1;
1092 SCM_I_ARRAY_V (ra_inr) = ra;
1093 SCM_I_ARRAY_BASE (ra_inr) = 0;
1096 else if (SCM_I_ARRAYP (ra))
1098 s = SCM_I_ARRAY_DIMS (ra);
1099 SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra);
1100 SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra);
1101 ndim = SCM_I_ARRAY_NDIM (ra);
1104 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1106 noutr = ndim - ninr;
1108 SCM_WRONG_NUM_ARGS ();
1109 axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
1110 res = scm_i_make_ra (noutr, 1);
1111 SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr);
1112 SCM_I_ARRAY_V (res) = ra_inr;
1113 for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
1115 if (!scm_is_integer (SCM_CAR (axes)))
1116 SCM_MISC_ERROR ("bad axis", SCM_EOL);
1117 j = scm_to_int (SCM_CAR (axes));
1118 SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
1119 SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
1120 SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
1121 scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1));
1123 c_axv = scm_i_string_chars (axv);
1124 for (j = 0, k = 0; k < noutr; k++, j++)
1128 SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
1129 SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
1130 SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc;
1132 scm_remember_upto_here_1 (axv);
1133 scm_i_ra_set_contp (ra_inr);
1134 scm_i_ra_set_contp (res);
1141 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
1143 "Return @code{#t} if its arguments would be acceptable to\n"
1144 "@code{array-ref}.")
1145 #define FUNC_NAME s_scm_array_in_bounds_p
1147 SCM res = SCM_BOOL_T;
1149 SCM_VALIDATE_REST_ARGUMENT (args);
1151 if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
1153 size_t k, ndim = SCM_I_ARRAY_NDIM (v);
1154 scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
1156 for (k = 0; k < ndim; k++)
1160 if (!scm_is_pair (args))
1161 SCM_WRONG_NUM_ARGS ();
1162 ind = scm_to_long (SCM_CAR (args));
1163 args = SCM_CDR (args);
1165 if (ind < s[k].lbnd || ind > s[k].ubnd)
1168 /* We do not stop the checking after finding a violation
1169 since we want to validate the type-correctness and
1170 number of arguments in any case.
1175 else if (scm_is_generalized_vector (v))
1177 /* Since real arrays have been covered above, all generalized
1178 vectors are guaranteed to be zero-origin here.
1183 if (!scm_is_pair (args))
1184 SCM_WRONG_NUM_ARGS ();
1185 ind = scm_to_long (SCM_CAR (args));
1186 args = SCM_CDR (args);
1187 res = scm_from_bool (ind >= 0
1188 && ind < scm_c_generalized_vector_length (v));
1191 scm_wrong_type_arg_msg (NULL, 0, v, "array");
1193 if (!scm_is_null (args))
1194 SCM_WRONG_NUM_ARGS ();
1201 scm_i_cvref (SCM v, size_t pos, int enclosed)
1205 int k = SCM_I_ARRAY_NDIM (v);
1206 SCM res = scm_i_make_ra (k, 0);
1207 SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v);
1208 SCM_I_ARRAY_BASE (res) = pos;
1211 SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd;
1212 SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd;
1213 SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc;
1218 return scm_c_generalized_vector_ref (v, pos);
1221 SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
1223 "Return the element at the @code{(index1, index2)} element in\n"
1225 #define FUNC_NAME s_scm_array_ref
1227 scm_t_array_handle handle;
1230 scm_array_get_handle (v, &handle);
1231 res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
1232 scm_array_handle_release (&handle);
1238 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
1239 (SCM v, SCM obj, SCM args),
1240 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1241 "@var{new-value}. The value returned by array-set! is unspecified.")
1242 #define FUNC_NAME s_scm_array_set_x
1244 scm_t_array_handle handle;
1246 scm_array_get_handle (v, &handle);
1247 scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
1248 scm_array_handle_release (&handle);
1249 return SCM_UNSPECIFIED;
1253 /* attempts to unroll an array into a one-dimensional array.
1254 returns the unrolled array or #f if it can't be done. */
1255 /* if strict is not SCM_UNDEFINED, return #f if returned array
1256 wouldn't have contiguous elements. */
1257 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1258 (SCM ra, SCM strict),
1259 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1260 "without changing their order (last subscript changing fastest), then\n"
1261 "@code{array-contents} returns that shared array, otherwise it returns\n"
1262 "@code{#f}. All arrays made by @var{make-array} and\n"
1263 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1264 "@var{make-shared-array} may not be.\n\n"
1265 "If the optional argument @var{strict} is provided, a shared array will\n"
1266 "be returned only if its elements are stored internally contiguous in\n"
1268 #define FUNC_NAME s_scm_array_contents
1272 if (scm_is_generalized_vector (ra))
1275 if (SCM_I_ARRAYP (ra))
1277 size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
1278 if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
1280 for (k = 0; k < ndim; k++)
1281 len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1282 if (!SCM_UNBNDP (strict))
1284 if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
1286 if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
1288 if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
1289 SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1296 SCM v = SCM_I_ARRAY_V (ra);
1297 size_t length = scm_c_generalized_vector_length (v);
1298 if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
1302 sra = scm_i_make_ra (1, 0);
1303 SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
1304 SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
1305 SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
1306 SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
1307 SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1310 else if (SCM_I_ENCLOSED_ARRAYP (ra))
1311 scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
1313 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
1319 scm_ra2contig (SCM ra, int copy)
1324 for (k = SCM_I_ARRAY_NDIM (ra); k--;)
1325 len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1326 k = SCM_I_ARRAY_NDIM (ra);
1327 if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
1329 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
1331 if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
1332 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1333 0 == len % SCM_LONG_BIT))
1336 ret = scm_i_make_ra (k, 0);
1337 SCM_I_ARRAY_BASE (ret) = 0;
1340 SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
1341 SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
1342 SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
1343 inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
1345 SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
1347 scm_array_copy_x (ra, ret);
1353 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1354 (SCM ura, SCM port_or_fd, SCM start, SCM end),
1355 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1356 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1357 "binary objects from @var{port-or-fdes}.\n"
1358 "If an end of file is encountered,\n"
1359 "the objects up to that point are put into @var{ura}\n"
1360 "(starting at the beginning) and the remainder of the array is\n"
1362 "The optional arguments @var{start} and @var{end} allow\n"
1363 "a specified region of a vector (or linearized array) to be read,\n"
1364 "leaving the remainder of the vector unchanged.\n\n"
1365 "@code{uniform-array-read!} returns the number of objects read.\n"
1366 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1367 "returned by @code{(current-input-port)}.")
1368 #define FUNC_NAME s_scm_uniform_array_read_x
1370 if (SCM_UNBNDP (port_or_fd))
1371 port_or_fd = scm_current_input_port ();
1373 if (scm_is_uniform_vector (ura))
1375 return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
1377 else if (SCM_I_ARRAYP (ura))
1379 size_t base, vlen, cstart, cend;
1382 cra = scm_ra2contig (ura, 0);
1383 base = SCM_I_ARRAY_BASE (cra);
1384 vlen = SCM_I_ARRAY_DIMS (cra)->inc *
1385 (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
1389 if (!SCM_UNBNDP (start))
1391 cstart = scm_to_unsigned_integer (start, 0, vlen);
1392 if (!SCM_UNBNDP (end))
1393 cend = scm_to_unsigned_integer (end, cstart, vlen);
1396 ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
1397 scm_from_size_t (base + cstart),
1398 scm_from_size_t (base + cend));
1400 if (!scm_is_eq (cra, ura))
1401 scm_array_copy_x (cra, ura);
1404 else if (SCM_I_ENCLOSED_ARRAYP (ura))
1405 scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
1407 scm_wrong_type_arg_msg (NULL, 0, ura, "array");
1411 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1412 (SCM ura, SCM port_or_fd, SCM start, SCM end),
1413 "Writes all elements of @var{ura} as binary objects to\n"
1414 "@var{port-or-fdes}.\n\n"
1415 "The optional arguments @var{start}\n"
1416 "and @var{end} allow\n"
1417 "a specified region of a vector (or linearized array) to be written.\n\n"
1418 "The number of objects actually written is returned.\n"
1419 "@var{port-or-fdes} may be\n"
1420 "omitted, in which case it defaults to the value returned by\n"
1421 "@code{(current-output-port)}.")
1422 #define FUNC_NAME s_scm_uniform_array_write
1424 if (SCM_UNBNDP (port_or_fd))
1425 port_or_fd = scm_current_output_port ();
1427 if (scm_is_uniform_vector (ura))
1429 return scm_uniform_vector_write (ura, port_or_fd, start, end);
1431 else if (SCM_I_ARRAYP (ura))
1433 size_t base, vlen, cstart, cend;
1436 cra = scm_ra2contig (ura, 1);
1437 base = SCM_I_ARRAY_BASE (cra);
1438 vlen = SCM_I_ARRAY_DIMS (cra)->inc *
1439 (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
1443 if (!SCM_UNBNDP (start))
1445 cstart = scm_to_unsigned_integer (start, 0, vlen);
1446 if (!SCM_UNBNDP (end))
1447 cend = scm_to_unsigned_integer (end, cstart, vlen);
1450 ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
1451 scm_from_size_t (base + cstart),
1452 scm_from_size_t (base + cend));
1456 else if (SCM_I_ENCLOSED_ARRAYP (ura))
1457 scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
1459 scm_wrong_type_arg_msg (NULL, 0, ura, "array");
1466 static scm_t_bits scm_tc16_bitvector;
1468 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1469 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1470 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1473 bitvector_free (SCM vec)
1475 scm_gc_free (BITVECTOR_BITS (vec),
1476 sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
1482 bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
1484 size_t bit_len = BITVECTOR_LENGTH (vec);
1485 size_t word_len = (bit_len+31)/32;
1486 scm_t_uint32 *bits = BITVECTOR_BITS (vec);
1489 scm_puts ("#*", port);
1490 for (i = 0; i < word_len; i++, bit_len -= 32)
1492 scm_t_uint32 mask = 1;
1493 for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
1494 scm_putc ((bits[i] & mask)? '1' : '0', port);
1501 bitvector_equalp (SCM vec1, SCM vec2)
1503 size_t bit_len = BITVECTOR_LENGTH (vec1);
1504 size_t word_len = (bit_len + 31) / 32;
1505 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
1506 scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
1507 scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
1509 /* compare lengths */
1510 if (BITVECTOR_LENGTH (vec2) != bit_len)
1512 /* avoid underflow in word_len-1 below. */
1515 /* compare full words */
1516 if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
1518 /* compare partial last words */
1519 if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
1525 scm_is_bitvector (SCM vec)
1527 return IS_BITVECTOR (vec);
1530 SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
1532 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1533 "return @code{#f}.")
1534 #define FUNC_NAME s_scm_bitvector_p
1536 return scm_from_bool (scm_is_bitvector (obj));
1541 scm_c_make_bitvector (size_t len, SCM fill)
1543 size_t word_len = (len + 31) / 32;
1547 bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
1549 SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
1551 if (!SCM_UNBNDP (fill))
1552 scm_bitvector_fill_x (res, fill);
1557 SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
1558 (SCM len, SCM fill),
1559 "Create a new bitvector of length @var{len} and\n"
1560 "optionally initialize all elements to @var{fill}.")
1561 #define FUNC_NAME s_scm_make_bitvector
1563 return scm_c_make_bitvector (scm_to_size_t (len), fill);
1567 SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
1569 "Create a new bitvector with the arguments as elements.")
1570 #define FUNC_NAME s_scm_bitvector
1572 return scm_list_to_bitvector (bits);
1577 scm_c_bitvector_length (SCM vec)
1579 scm_assert_smob_type (scm_tc16_bitvector, vec);
1580 return BITVECTOR_LENGTH (vec);
1583 SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
1585 "Return the length of the bitvector @var{vec}.")
1586 #define FUNC_NAME s_scm_bitvector_length
1588 return scm_from_size_t (scm_c_bitvector_length (vec));
1592 const scm_t_uint32 *
1593 scm_array_handle_bit_elements (scm_t_array_handle *h)
1595 return scm_array_handle_bit_writable_elements (h);
1599 scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
1602 if (SCM_I_ARRAYP (vec))
1603 vec = SCM_I_ARRAY_V (vec);
1604 if (IS_BITVECTOR (vec))
1605 return BITVECTOR_BITS (vec) + h->base/32;
1606 scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
1610 scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
1612 return h->base % 32;
1615 const scm_t_uint32 *
1616 scm_bitvector_elements (SCM vec,
1617 scm_t_array_handle *h,
1622 return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
1627 scm_bitvector_writable_elements (SCM vec,
1628 scm_t_array_handle *h,
1633 scm_generalized_vector_get_handle (vec, h);
1636 scm_t_array_dim *dim = scm_array_handle_dims (h);
1637 *offp = scm_array_handle_bit_elements_offset (h);
1638 *lenp = dim->ubnd - dim->lbnd + 1;
1641 return scm_array_handle_bit_writable_elements (h);
1645 scm_c_bitvector_ref (SCM vec, size_t idx)
1647 scm_t_array_handle handle;
1648 const scm_t_uint32 *bits;
1650 if (IS_BITVECTOR (vec))
1652 if (idx >= BITVECTOR_LENGTH (vec))
1653 scm_out_of_range (NULL, scm_from_size_t (idx));
1654 bits = BITVECTOR_BITS(vec);
1655 return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
1663 bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
1665 scm_out_of_range (NULL, scm_from_size_t (idx));
1666 idx = idx*inc + off;
1667 res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
1668 scm_array_handle_release (&handle);
1673 SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
1675 "Return the element at index @var{idx} of the bitvector\n"
1677 #define FUNC_NAME s_scm_bitvector_ref
1679 return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
1684 scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
1686 scm_t_array_handle handle;
1687 scm_t_uint32 *bits, mask;
1689 if (IS_BITVECTOR (vec))
1691 if (idx >= BITVECTOR_LENGTH (vec))
1692 scm_out_of_range (NULL, scm_from_size_t (idx));
1693 bits = BITVECTOR_BITS(vec);
1700 bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
1702 scm_out_of_range (NULL, scm_from_size_t (idx));
1703 idx = idx*inc + off;
1706 mask = 1L << (idx%32);
1707 if (scm_is_true (val))
1708 bits[idx/32] |= mask;
1710 bits[idx/32] &= ~mask;
1712 if (!IS_BITVECTOR (vec))
1713 scm_array_handle_release (&handle);
1716 SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
1717 (SCM vec, SCM idx, SCM val),
1718 "Set the element at index @var{idx} of the bitvector\n"
1719 "@var{vec} when @var{val} is true, else clear it.")
1720 #define FUNC_NAME s_scm_bitvector_set_x
1722 scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
1723 return SCM_UNSPECIFIED;
1727 SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
1729 "Set all elements of the bitvector\n"
1730 "@var{vec} when @var{val} is true, else clear them.")
1731 #define FUNC_NAME s_scm_bitvector_fill_x
1733 scm_t_array_handle handle;
1738 bits = scm_bitvector_writable_elements (vec, &handle,
1741 if (off == 0 && inc == 1 && len > 0)
1745 size_t word_len = (len + 31) / 32;
1746 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
1748 if (scm_is_true (val))
1750 memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
1751 bits[word_len-1] |= last_mask;
1755 memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
1756 bits[word_len-1] &= ~last_mask;
1762 for (i = 0; i < len; i++)
1763 scm_array_handle_set (&handle, i*inc, val);
1766 scm_array_handle_release (&handle);
1768 return SCM_UNSPECIFIED;
1772 SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
1774 "Return a new bitvector initialized with the elements\n"
1776 #define FUNC_NAME s_scm_list_to_bitvector
1778 size_t bit_len = scm_to_size_t (scm_length (list));
1779 SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
1780 size_t word_len = (bit_len+31)/32;
1781 scm_t_array_handle handle;
1782 scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
1786 for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
1788 scm_t_uint32 mask = 1;
1790 for (j = 0; j < 32 && j < bit_len;
1791 j++, mask <<= 1, list = SCM_CDR (list))
1792 if (scm_is_true (SCM_CAR (list)))
1796 scm_array_handle_release (&handle);
1802 SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
1804 "Return a new list initialized with the elements\n"
1805 "of the bitvector @var{vec}.")
1806 #define FUNC_NAME s_scm_bitvector_to_list
1808 scm_t_array_handle handle;
1814 bits = scm_bitvector_writable_elements (vec, &handle,
1817 if (off == 0 && inc == 1)
1821 size_t word_len = (len + 31) / 32;
1824 for (i = 0; i < word_len; i++, len -= 32)
1826 scm_t_uint32 mask = 1;
1827 for (j = 0; j < 32 && j < len; j++, mask <<= 1)
1828 res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
1834 for (i = 0; i < len; i++)
1835 res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
1838 scm_array_handle_release (&handle);
1840 return scm_reverse_x (res, SCM_EOL);
1844 /* From mmix-arith.w by Knuth.
1846 Here's a fun way to count the number of bits in a tetrabyte.
1848 [This classical trick is called the ``Gillies--Miller method for
1849 sideways addition'' in {\sl The Preparation of Programs for an
1850 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1851 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1852 the tricks used here were suggested by Balbir Singh, Peter
1853 Rossmanith, and Stefan Schwoon.]
1857 count_ones (scm_t_uint32 x)
1859 x=x-((x>>1)&0x55555555);
1860 x=(x&0x33333333)+((x>>2)&0x33333333);
1861 x=(x+(x>>4))&0x0f0f0f0f;
1863 return (x+(x>>16)) & 0xff;
1866 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1867 (SCM b, SCM bitvector),
1868 "Return the number of occurrences of the boolean @var{b} in\n"
1870 #define FUNC_NAME s_scm_bit_count
1872 scm_t_array_handle handle;
1876 int bit = scm_to_bool (b);
1879 bits = scm_bitvector_writable_elements (bitvector, &handle,
1882 if (off == 0 && inc == 1 && len > 0)
1886 size_t word_len = (len + 31) / 32;
1887 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
1890 for (i = 0; i < word_len-1; i++)
1891 count += count_ones (bits[i]);
1892 count += count_ones (bits[i] & last_mask);
1897 for (i = 0; i < len; i++)
1898 if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
1902 scm_array_handle_release (&handle);
1904 return scm_from_size_t (bit? count : len-count);
1908 /* returns 32 for x == 0.
1911 find_first_one (scm_t_uint32 x)
1914 /* do a binary search in x. */
1915 if ((x & 0xFFFF) == 0)
1916 x >>= 16, pos += 16;
1917 if ((x & 0xFF) == 0)
1928 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1929 (SCM item, SCM v, SCM k),
1930 "Return the index of the first occurrance of @var{item} in bit\n"
1931 "vector @var{v}, starting from @var{k}. If there is no\n"
1932 "@var{item} entry between @var{k} and the end of\n"
1933 "@var{bitvector}, then return @code{#f}. For example,\n"
1936 "(bit-position #t #*000101 0) @result{} 3\n"
1937 "(bit-position #f #*0001111 3) @result{} #f\n"
1939 #define FUNC_NAME s_scm_bit_position
1941 scm_t_array_handle handle;
1942 size_t off, len, first_bit;
1944 const scm_t_uint32 *bits;
1945 int bit = scm_to_bool (item);
1946 SCM res = SCM_BOOL_F;
1948 bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
1949 first_bit = scm_to_unsigned_integer (k, 0, len);
1951 if (off == 0 && inc == 1 && len > 0)
1953 size_t i, word_len = (len + 31) / 32;
1954 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
1955 size_t first_word = first_bit / 32;
1956 scm_t_uint32 first_mask =
1957 ((scm_t_uint32)-1) << (first_bit - 32*first_word);
1960 for (i = first_word; i < word_len; i++)
1962 w = (bit? bits[i] : ~bits[i]);
1963 if (i == first_word)
1965 if (i == word_len-1)
1969 res = scm_from_size_t (32*i + find_first_one (w));
1977 for (i = first_bit; i < len; i++)
1979 SCM elt = scm_array_handle_ref (&handle, i*inc);
1980 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
1982 res = scm_from_size_t (i);
1988 scm_array_handle_release (&handle);
1994 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1995 (SCM v, SCM kv, SCM obj),
1996 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1997 "selecting the entries to change. The return value is\n"
2000 "If @var{kv} is a bit vector, then those entries where it has\n"
2001 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
2002 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
2003 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
2004 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
2007 "(define bv #*01000010)\n"
2008 "(bit-set*! bv #*10010001 #t)\n"
2010 "@result{} #*11010011\n"
2013 "If @var{kv} is a u32vector, then its elements are\n"
2014 "indices into @var{v} which are set to @var{obj}.\n"
2017 "(define bv #*01000010)\n"
2018 "(bit-set*! bv #u32(5 2 7) #t)\n"
2020 "@result{} #*01100111\n"
2022 #define FUNC_NAME s_scm_bit_set_star_x
2024 scm_t_array_handle v_handle;
2025 size_t v_off, v_len;
2027 scm_t_uint32 *v_bits;
2030 /* Validate that OBJ is a boolean so this is done even if we don't
2033 bit = scm_to_bool (obj);
2035 v_bits = scm_bitvector_writable_elements (v, &v_handle,
2036 &v_off, &v_len, &v_inc);
2038 if (scm_is_bitvector (kv))
2040 scm_t_array_handle kv_handle;
2041 size_t kv_off, kv_len;
2043 const scm_t_uint32 *kv_bits;
2045 kv_bits = scm_bitvector_elements (v, &kv_handle,
2046 &kv_off, &kv_len, &kv_inc);
2048 if (v_len != kv_len)
2049 scm_misc_error (NULL,
2050 "bit vectors must have equal length",
2053 if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
2055 size_t word_len = (kv_len + 31) / 32;
2056 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
2061 for (i = 0; i < word_len-1; i++)
2062 v_bits[i] &= ~kv_bits[i];
2063 v_bits[i] &= ~(kv_bits[i] & last_mask);
2067 for (i = 0; i < word_len-1; i++)
2068 v_bits[i] |= kv_bits[i];
2069 v_bits[i] |= kv_bits[i] & last_mask;
2075 for (i = 0; i < kv_len; i++)
2076 if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
2077 scm_array_handle_set (&v_handle, i*v_inc, obj);
2080 scm_array_handle_release (&kv_handle);
2083 else if (scm_is_true (scm_u32vector_p (kv)))
2085 scm_t_array_handle kv_handle;
2088 const scm_t_uint32 *kv_elts;
2090 kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
2091 for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
2092 scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
2094 scm_array_handle_release (&kv_handle);
2097 scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
2099 scm_array_handle_release (&v_handle);
2101 return SCM_UNSPECIFIED;
2106 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
2107 (SCM v, SCM kv, SCM obj),
2108 "Return a count of how many entries in bit vector @var{v} are\n"
2109 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2112 "If @var{kv} is a bit vector, then those entries where it has\n"
2113 "@code{#t} are the ones in @var{v} which are considered.\n"
2114 "@var{kv} and @var{v} must be the same length.\n"
2116 "If @var{kv} is a u32vector, then it contains\n"
2117 "the indexes in @var{v} to consider.\n"
2122 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2123 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2125 #define FUNC_NAME s_scm_bit_count_star
2127 scm_t_array_handle v_handle;
2128 size_t v_off, v_len;
2130 const scm_t_uint32 *v_bits;
2134 /* Validate that OBJ is a boolean so this is done even if we don't
2137 bit = scm_to_bool (obj);
2139 v_bits = scm_bitvector_elements (v, &v_handle,
2140 &v_off, &v_len, &v_inc);
2142 if (scm_is_bitvector (kv))
2144 scm_t_array_handle kv_handle;
2145 size_t kv_off, kv_len;
2147 const scm_t_uint32 *kv_bits;
2149 kv_bits = scm_bitvector_elements (v, &kv_handle,
2150 &kv_off, &kv_len, &kv_inc);
2152 if (v_len != kv_len)
2153 scm_misc_error (NULL,
2154 "bit vectors must have equal length",
2157 if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
2159 size_t i, word_len = (kv_len + 31) / 32;
2160 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
2161 scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
2163 for (i = 0; i < word_len-1; i++)
2164 count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
2165 count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
2170 for (i = 0; i < kv_len; i++)
2171 if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
2173 SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
2174 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
2179 scm_array_handle_release (&kv_handle);
2182 else if (scm_is_true (scm_u32vector_p (kv)))
2184 scm_t_array_handle kv_handle;
2187 const scm_t_uint32 *kv_elts;
2189 kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
2190 for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
2192 SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
2193 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
2197 scm_array_handle_release (&kv_handle);
2200 scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
2202 scm_array_handle_release (&v_handle);
2204 return scm_from_size_t (count);
2208 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
2210 "Modify the bit vector @var{v} by replacing each element with\n"
2212 #define FUNC_NAME s_scm_bit_invert_x
2214 scm_t_array_handle handle;
2219 bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
2221 if (off == 0 && inc == 1 && len > 0)
2223 size_t word_len = (len + 31) / 32;
2224 scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
2227 for (i = 0; i < word_len-1; i++)
2229 bits[i] = bits[i] ^ last_mask;
2234 for (i = 0; i < len; i++)
2235 scm_array_handle_set (&handle, i*inc,
2236 scm_not (scm_array_handle_ref (&handle, i*inc)));
2239 scm_array_handle_release (&handle);
2241 return SCM_UNSPECIFIED;
2247 scm_istr2bve (SCM str)
2249 scm_t_array_handle handle;
2250 size_t len = scm_i_string_length (str);
2251 SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
2259 data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
2260 c_str = scm_i_string_chars (str);
2262 for (k = 0; k < (len + 31) / 32; k++)
2268 for (mask = 1L; j--; mask <<= 1)
2283 scm_array_handle_release (&handle);
2284 scm_remember_upto_here_1 (str);
2291 ra2l (SCM ra, unsigned long base, unsigned long k)
2296 int enclosed = SCM_I_ENCLOSED_ARRAYP (ra);
2298 if (k == SCM_I_ARRAY_NDIM (ra))
2299 return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed);
2301 inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
2302 if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
2304 i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
2308 res = scm_cons (ra2l (ra, i, k + 1), res);
2315 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
2317 "Return a list consisting of all the elements, in order, of\n"
2319 #define FUNC_NAME s_scm_array_to_list
2321 if (scm_is_generalized_vector (v))
2322 return scm_generalized_vector_to_list (v);
2323 else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
2324 return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
2326 scm_wrong_type_arg_msg (NULL, 0, v, "array");
2331 static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
2333 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
2334 (SCM type, SCM shape, SCM lst),
2335 "Return an array of the type @var{type}\n"
2336 "with elements the same as those of @var{lst}.\n"
2338 "The argument @var{shape} determines the number of dimensions\n"
2339 "of the array and their shape. It is either an exact integer,\n"
2341 "number of dimensions directly, or a list whose length\n"
2342 "specifies the number of dimensions and each element specified\n"
2343 "the lower and optionally the upper bound of the corresponding\n"
2345 "When the element is list of two elements, these elements\n"
2346 "give the lower and upper bounds. When it is an exact\n"
2347 "integer, it gives only the lower bound.")
2348 #define FUNC_NAME s_scm_list_to_typed_array
2352 scm_t_array_handle handle;
2355 if (scm_is_integer (shape))
2357 size_t k = scm_to_size_t (shape);
2361 shape = scm_cons (scm_length (row), shape);
2362 if (k > 0 && !scm_is_null (row))
2363 row = scm_car (row);
2368 SCM shape_spec = shape;
2372 SCM spec = scm_car (shape_spec);
2373 if (scm_is_pair (spec))
2374 shape = scm_cons (spec, shape);
2376 shape = scm_cons (scm_list_2 (spec,
2377 scm_sum (scm_sum (spec,
2379 scm_from_int (-1))),
2381 shape_spec = scm_cdr (shape_spec);
2382 if (scm_is_pair (shape_spec))
2384 if (!scm_is_null (row))
2385 row = scm_car (row);
2392 ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
2393 scm_reverse_x (shape, SCM_EOL));
2395 scm_array_get_handle (ra, &handle);
2396 l2ra (lst, &handle, 0, 0);
2397 scm_array_handle_release (&handle);
2403 SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
2404 (SCM ndim, SCM lst),
2405 "Return an array with elements the same as those of @var{lst}.")
2406 #define FUNC_NAME s_scm_list_to_array
2408 return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
2413 l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
2415 if (k == scm_array_handle_rank (handle))
2416 scm_array_handle_set (handle, pos, lst);
2419 scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
2420 ssize_t inc = dim->inc;
2421 size_t len = 1 + dim->ubnd - dim->lbnd, n;
2422 char *errmsg = NULL;
2425 while (n > 0 && scm_is_pair (lst))
2427 l2ra (SCM_CAR (lst), handle, pos, k + 1);
2429 lst = SCM_CDR (lst);
2433 errmsg = "too few elements for array dimension ~a, need ~a";
2434 if (!scm_is_null (lst))
2435 errmsg = "too many elements for array dimension ~a, want ~a";
2437 scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
2438 scm_from_size_t (len)));
2442 #if SCM_ENABLE_DEPRECATED
2444 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2445 (SCM ndim, SCM prot, SCM lst),
2446 "Return a uniform array of the type indicated by prototype\n"
2447 "@var{prot} with elements the same as those of @var{lst}.\n"
2448 "Elements must be of the appropriate type, no coercions are\n"
2451 "The argument @var{ndim} determines the number of dimensions\n"
2452 "of the array. It is either an exact integer, giving the\n"
2453 "number directly, or a list of exact integers, whose length\n"
2454 "specifies the number of dimensions and each element is the\n"
2455 "lower index bound of its dimension.")
2456 #define FUNC_NAME s_scm_list_to_uniform_array
2458 return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst);
2464 /* Print dimension DIM of ARRAY.
2468 scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
2469 SCM port, scm_print_state *pstate)
2471 scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
2474 scm_putc ('(', port);
2476 for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
2478 if (dim < SCM_I_ARRAY_NDIM(array)-1)
2479 scm_i_print_array_dimension (array, dim+1, base, enclosed,
2482 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed),
2484 if (idx < dim_spec->ubnd)
2485 scm_putc (' ', port);
2486 base += dim_spec->inc;
2489 scm_putc (')', port);
2493 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2497 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
2499 long ndim = SCM_I_ARRAY_NDIM (array);
2500 scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
2501 SCM v = SCM_I_ARRAY_V (array);
2502 unsigned long base = SCM_I_ARRAY_BASE (array);
2504 int print_lbnds = 0, zero_size = 0, print_lens = 0;
2506 scm_putc ('#', port);
2507 if (ndim != 1 || dim_specs[0].lbnd != 0)
2508 scm_intprint (ndim, 10, port);
2509 if (scm_is_uniform_vector (v))
2510 scm_puts (scm_i_uniform_vector_tag (v), port);
2511 else if (scm_is_bitvector (v))
2512 scm_puts ("b", port);
2513 else if (scm_is_string (v))
2514 scm_puts ("a", port);
2515 else if (!scm_is_vector (v))
2516 scm_puts ("?", port);
2518 for (i = 0; i < ndim; i++)
2520 if (dim_specs[i].lbnd != 0)
2522 if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
2528 if (print_lbnds || print_lens)
2529 for (i = 0; i < ndim; i++)
2533 scm_putc ('@', port);
2534 scm_intprint (dim_specs[i].lbnd, 10, port);
2538 scm_putc (':', port);
2539 scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
2546 /* Rank zero arrays, which are really just scalars, are printed
2547 specially. The consequent way would be to print them as
2551 where OBJ is the printed representation of the scalar, but we
2552 print them instead as
2556 to make them look less strange.
2558 Just printing them as
2562 would be correct in a way as well, but zero rank arrays are
2563 not really the same as Scheme values since they are boxed and
2564 can be modified with array-set!, say.
2566 scm_putc ('(', port);
2567 scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate);
2568 scm_putc (')', port);
2572 return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
2576 scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate)
2580 scm_putc ('#', port);
2581 base = SCM_I_ARRAY_BASE (array);
2582 scm_puts ("<enclosed-array ", port);
2583 scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
2584 scm_putc ('>', port);
2588 /* Read an array. This function can also read vectors and uniform
2589 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2592 C is the first character read after the '#'.
2596 tag_to_type (const char *tag, SCM port)
2598 #if SCM_ENABLE_DEPRECATED
2600 /* Recognize the old syntax.
2602 const char *instead;
2634 if (instead && tag[1] == '\0')
2636 scm_c_issue_deprecation_warning_fmt
2637 ("The tag '%c' is deprecated for uniform vectors. "
2638 "Use '%s' instead.", tag[0], instead);
2639 return scm_from_locale_symbol (instead);
2647 return scm_from_locale_symbol (tag);
2651 read_decimal_integer (SCM port, int c, ssize_t *resp)
2660 c = scm_getc (port);
2663 while ('0' <= c && c <= '9')
2665 res = 10*res + c-'0';
2667 c = scm_getc (port);
2676 scm_i_read_array (SCM port, int c)
2683 SCM shape = SCM_BOOL_F, elements;
2685 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2686 the array code can not deal with zero-length dimensions yet, and
2687 we want to allow zero-length vectors, of course.
2691 scm_ungetc (c, port);
2692 return scm_vector (scm_read (port));
2695 /* Disambiguate between '#f' and uniform floating point vectors.
2699 c = scm_getc (port);
2700 if (c != '3' && c != '6')
2703 scm_ungetc (c, port);
2710 goto continue_reading_tag;
2716 c = read_decimal_integer (port, c, &rank);
2718 scm_i_input_error (NULL, port, "array rank must be non-negative",
2724 continue_reading_tag:
2725 while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
2728 c = scm_getc (port);
2730 tag[tag_len] = '\0';
2734 if (c == '@' || c == ':')
2740 ssize_t lbnd = 0, len = 0;
2745 c = scm_getc (port);
2746 c = read_decimal_integer (port, c, &lbnd);
2749 s = scm_from_ssize_t (lbnd);
2753 c = scm_getc (port);
2754 c = read_decimal_integer (port, c, &len);
2756 scm_i_input_error (NULL, port,
2757 "array length must be non-negative",
2760 s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
2763 shape = scm_cons (s, shape);
2764 } while (c == '@' || c == ':');
2766 shape = scm_reverse_x (shape, SCM_EOL);
2769 /* Read nested lists of elements.
2772 scm_i_input_error (NULL, port,
2773 "missing '(' in vector or array literal",
2775 scm_ungetc (c, port);
2776 elements = scm_read (port);
2778 if (scm_is_false (shape))
2779 shape = scm_from_ssize_t (rank);
2780 else if (scm_ilength (shape) != rank)
2783 "the number of shape specifications must match the array rank",
2786 /* Handle special print syntax of rank zero arrays; see
2787 scm_i_print_array for a rationale.
2791 if (!scm_is_pair (elements))
2792 scm_i_input_error (NULL, port,
2793 "too few elements in array literal, need 1",
2795 if (!scm_is_null (SCM_CDR (elements)))
2796 scm_i_input_error (NULL, port,
2797 "too many elements in array literal, want 1",
2799 elements = SCM_CAR (elements);
2804 return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
2807 SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
2810 #define FUNC_NAME s_scm_array_type
2812 if (SCM_I_ARRAYP (ra))
2813 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
2814 else if (scm_is_generalized_vector (ra))
2815 return scm_i_generalized_vector_type (ra);
2816 else if (SCM_I_ENCLOSED_ARRAYP (ra))
2817 scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
2819 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
2823 #if SCM_ENABLE_DEPRECATED
2825 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2827 "Return an object that would produce an array of the same type\n"
2828 "as @var{array}, if used as the @var{prototype} for\n"
2829 "@code{make-uniform-array}.")
2830 #define FUNC_NAME s_scm_array_prototype
2832 if (SCM_I_ARRAYP (ra))
2833 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra));
2834 else if (scm_is_generalized_vector (ra))
2835 return scm_i_get_old_prototype (ra);
2836 else if (SCM_I_ENCLOSED_ARRAYP (ra))
2837 return SCM_UNSPECIFIED;
2839 scm_wrong_type_arg_msg (NULL, 0, ra, "array");
2846 array_mark (SCM ptr)
2848 return SCM_I_ARRAY_V (ptr);
2852 array_free (SCM ptr)
2854 scm_gc_free (SCM_I_ARRAY_MEM (ptr),
2855 (sizeof (scm_i_t_array)
2856 + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
2861 #if SCM_ENABLE_DEPRECATED
2864 scm_make_ra (int ndim)
2866 scm_c_issue_deprecation_warning
2867 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2868 return scm_i_make_ra (ndim, 0);
2872 scm_shap2ra (SCM args, const char *what)
2874 scm_c_issue_deprecation_warning
2875 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2876 return scm_i_shap2ra (args);
2880 scm_cvref (SCM v, unsigned long pos, SCM last)
2882 scm_c_issue_deprecation_warning
2883 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2884 return scm_c_generalized_vector_ref (v, pos);
2888 scm_ra_set_contp (SCM ra)
2890 scm_c_issue_deprecation_warning
2891 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2892 scm_i_ra_set_contp (ra);
2896 scm_aind (SCM ra, SCM args, const char *what)
2898 scm_t_array_handle handle;
2901 scm_c_issue_deprecation_warning
2902 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2904 if (scm_is_integer (args))
2905 args = scm_list_1 (args);
2907 scm_array_get_handle (ra, &handle);
2908 pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
2909 scm_array_handle_release (&handle);
2914 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2916 scm_c_issue_deprecation_warning
2917 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2919 scm_iprin1 (exp, port, pstate);
2928 scm_i_tc16_array = scm_make_smob_type ("array", 0);
2929 scm_set_smob_mark (scm_i_tc16_array, array_mark);
2930 scm_set_smob_free (scm_i_tc16_array, array_free);
2931 scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
2932 scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
2934 scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
2935 scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
2936 scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
2937 scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array);
2938 scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p);
2940 scm_add_feature ("array");
2942 scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
2943 scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
2944 scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
2945 scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
2947 init_type_creator_table ();
2949 #include "libguile/unif.x"