1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005 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 return scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
373 return 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
->elements
)[pos
/32] |= mask
;
385 ((scm_t_uint32
*)h
->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
);
799 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
806 scm_i_ra_set_contp (SCM ra
)
808 size_t k
= SCM_I_ARRAY_NDIM (ra
);
811 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
814 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
816 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
819 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
820 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
823 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
827 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
828 (SCM oldra
, SCM mapfunc
, SCM dims
),
829 "@code{make-shared-array} can be used to create shared subarrays of other\n"
830 "arrays. The @var{mapper} is a function that translates coordinates in\n"
831 "the new array into coordinates in the old array. A @var{mapper} must be\n"
832 "linear, and its range must stay within the bounds of the old array, but\n"
833 "it can be otherwise arbitrary. A simple example:\n"
835 "(define fred (make-array #f 8 8))\n"
836 "(define freds-diagonal\n"
837 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
838 "(array-set! freds-diagonal 'foo 3)\n"
839 "(array-ref fred 3 3) @result{} foo\n"
840 "(define freds-center\n"
841 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
842 "(array-ref freds-center 0 0) @result{} foo\n"
844 #define FUNC_NAME s_scm_make_shared_array
846 scm_t_array_handle old_handle
;
852 long old_min
, new_min
, old_max
, new_max
;
855 SCM_VALIDATE_REST_ARGUMENT (dims
);
856 SCM_VALIDATE_PROC (2, mapfunc
);
857 ra
= scm_i_shap2ra (dims
);
859 scm_array_get_handle (oldra
, &old_handle
);
861 if (SCM_I_ARRAYP (oldra
))
863 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
864 old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
865 s
= scm_array_handle_dims (&old_handle
);
866 k
= scm_array_handle_rank (&old_handle
);
870 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
872 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
877 SCM_I_ARRAY_V (ra
) = oldra
;
879 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
883 s
= SCM_I_ARRAY_DIMS (ra
);
884 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
886 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
887 if (s
[k
].ubnd
< s
[k
].lbnd
)
889 if (1 == SCM_I_ARRAY_NDIM (ra
))
890 ra
= make_typed_vector (scm_array_type (ra
), 0);
892 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
893 scm_array_handle_release (&old_handle
);
898 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
899 i
= scm_array_handle_pos (&old_handle
, imap
);
900 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ SCM_I_ARRAY_BASE (oldra
);
902 k
= SCM_I_ARRAY_NDIM (ra
);
905 if (s
[k
].ubnd
> s
[k
].lbnd
)
907 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
908 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
909 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
912 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
914 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
917 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
918 indptr
= SCM_CDR (indptr
);
921 scm_array_handle_release (&old_handle
);
923 if (old_min
> new_min
|| old_max
< new_max
)
924 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
925 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
927 SCM v
= SCM_I_ARRAY_V (ra
);
928 size_t length
= scm_c_generalized_vector_length (v
);
929 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
931 if (s
->ubnd
< s
->lbnd
)
932 return make_typed_vector (scm_array_type (ra
), 0);
934 scm_i_ra_set_contp (ra
);
940 /* args are RA . DIMS */
941 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
943 "Return an array sharing contents with @var{array}, but with\n"
944 "dimensions arranged in a different order. There must be one\n"
945 "@var{dim} argument for each dimension of @var{array}.\n"
946 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
947 "and the rank of the array to be returned. Each integer in that\n"
948 "range must appear at least once in the argument list.\n"
950 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
951 "dimensions in the array to be returned, their positions in the\n"
952 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
953 "may have the same value, in which case the returned array will\n"
954 "have smaller rank than @var{array}.\n"
957 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
958 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
959 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
960 " #2((a 4) (b 5) (c 6))\n"
962 #define FUNC_NAME s_scm_transpose_array
965 scm_t_array_dim
*s
, *r
;
968 SCM_VALIDATE_REST_ARGUMENT (args
);
969 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
971 if (scm_is_generalized_vector (ra
))
973 /* Make sure that we are called with a single zero as
976 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
977 SCM_WRONG_NUM_ARGS ();
978 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
979 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
983 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
985 vargs
= scm_vector (args
);
986 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
987 SCM_WRONG_NUM_ARGS ();
989 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
991 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
992 0, SCM_I_ARRAY_NDIM(ra
));
997 res
= scm_i_make_ra (ndim
, 0);
998 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
999 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
1000 for (k
= ndim
; k
--;)
1002 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
1003 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
1005 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1007 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
1008 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
1009 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
1010 if (r
->ubnd
< r
->lbnd
)
1019 if (r
->ubnd
> s
->ubnd
)
1021 if (r
->lbnd
< s
->lbnd
)
1023 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1030 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1031 scm_i_ra_set_contp (res
);
1035 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1039 /* args are RA . AXES */
1040 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1042 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1043 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1044 "resembling an array of shared arrays. The dimensions of each shared\n"
1045 "array are the same as the @var{dim}th dimensions of the original array,\n"
1046 "the dimensions of the outer array are the same as those of the original\n"
1047 "array that did not match a @var{dim}.\n\n"
1048 "An enclosed array is not a general Scheme array. Its elements may not\n"
1049 "be set using @code{array-set!}. Two references to the same element of\n"
1050 "an enclosed array will be @code{equal?} but will not in general be\n"
1051 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1052 "enclosed array is unspecified.\n\n"
1055 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1056 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1057 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1058 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1060 #define FUNC_NAME s_scm_enclose_array
1062 SCM axv
, res
, ra_inr
;
1064 scm_t_array_dim vdim
, *s
= &vdim
;
1065 int ndim
, j
, k
, ninr
, noutr
;
1067 SCM_VALIDATE_REST_ARGUMENT (axes
);
1068 if (scm_is_null (axes
))
1069 axes
= scm_cons ((SCM_I_ARRAYP (ra
) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1070 ninr
= scm_ilength (axes
);
1072 SCM_WRONG_NUM_ARGS ();
1073 ra_inr
= scm_i_make_ra (ninr
, 0);
1075 if (scm_is_generalized_vector (ra
))
1078 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1080 SCM_I_ARRAY_V (ra_inr
) = ra
;
1081 SCM_I_ARRAY_BASE (ra_inr
) = 0;
1084 else if (SCM_I_ARRAYP (ra
))
1086 s
= SCM_I_ARRAY_DIMS (ra
);
1087 SCM_I_ARRAY_V (ra_inr
) = SCM_I_ARRAY_V (ra
);
1088 SCM_I_ARRAY_BASE (ra_inr
) = SCM_I_ARRAY_BASE (ra
);
1089 ndim
= SCM_I_ARRAY_NDIM (ra
);
1092 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1094 noutr
= ndim
- ninr
;
1096 SCM_WRONG_NUM_ARGS ();
1097 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1098 res
= scm_i_make_ra (noutr
, 1);
1099 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra_inr
);
1100 SCM_I_ARRAY_V (res
) = ra_inr
;
1101 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1103 if (!scm_is_integer (SCM_CAR (axes
)))
1104 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1105 j
= scm_to_int (SCM_CAR (axes
));
1106 SCM_I_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1107 SCM_I_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1108 SCM_I_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1109 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1111 c_axv
= scm_i_string_chars (axv
);
1112 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1116 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1117 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1118 SCM_I_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1120 scm_remember_upto_here_1 (axv
);
1121 scm_i_ra_set_contp (ra_inr
);
1122 scm_i_ra_set_contp (res
);
1129 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1131 "Return @code{#t} if its arguments would be acceptable to\n"
1132 "@code{array-ref}.")
1133 #define FUNC_NAME s_scm_array_in_bounds_p
1135 SCM res
= SCM_BOOL_T
;
1137 SCM_VALIDATE_REST_ARGUMENT (args
);
1139 if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
1141 size_t k
= SCM_I_ARRAY_NDIM (v
);
1142 scm_t_array_dim
*s
= SCM_I_ARRAY_DIMS (v
);
1148 if (!scm_is_pair (args
))
1149 SCM_WRONG_NUM_ARGS ();
1150 ind
= scm_to_long (SCM_CAR (args
));
1151 args
= SCM_CDR (args
);
1154 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1157 /* We do not stop the checking after finding a violation
1158 since we want to validate the type-correctness and
1159 number of arguments in any case.
1164 else if (scm_is_generalized_vector (v
))
1166 /* Since real arrays have been covered above, all generalized
1167 vectors are guaranteed to be zero-origin here.
1172 if (!scm_is_pair (args
))
1173 SCM_WRONG_NUM_ARGS ();
1174 ind
= scm_to_long (SCM_CAR (args
));
1175 args
= SCM_CDR (args
);
1176 res
= scm_from_bool (ind
>= 0
1177 && ind
< scm_c_generalized_vector_length (v
));
1180 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1182 if (!scm_is_null (args
))
1183 SCM_WRONG_NUM_ARGS ();
1190 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1194 int k
= SCM_I_ARRAY_NDIM (v
);
1195 SCM res
= scm_i_make_ra (k
, 0);
1196 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (v
);
1197 SCM_I_ARRAY_BASE (res
) = pos
;
1200 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= SCM_I_ARRAY_DIMS (v
)[k
].ubnd
;
1201 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= SCM_I_ARRAY_DIMS (v
)[k
].lbnd
;
1202 SCM_I_ARRAY_DIMS (res
)[k
].inc
= SCM_I_ARRAY_DIMS (v
)[k
].inc
;
1207 return scm_c_generalized_vector_ref (v
, pos
);
1210 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1212 "Return the element at the @code{(index1, index2)} element in\n"
1214 #define FUNC_NAME s_scm_array_ref
1216 scm_t_array_handle handle
;
1219 scm_array_get_handle (v
, &handle
);
1220 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
1221 scm_array_handle_release (&handle
);
1227 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1228 (SCM v
, SCM obj
, SCM args
),
1229 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1230 "@var{new-value}. The value returned by array-set! is unspecified.")
1231 #define FUNC_NAME s_scm_array_set_x
1233 scm_t_array_handle handle
;
1235 scm_array_get_handle (v
, &handle
);
1236 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
1237 scm_array_handle_release (&handle
);
1238 return SCM_UNSPECIFIED
;
1242 /* attempts to unroll an array into a one-dimensional array.
1243 returns the unrolled array or #f if it can't be done. */
1244 /* if strict is not SCM_UNDEFINED, return #f if returned array
1245 wouldn't have contiguous elements. */
1246 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1247 (SCM ra
, SCM strict
),
1248 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1249 "without changing their order (last subscript changing fastest), then\n"
1250 "@code{array-contents} returns that shared array, otherwise it returns\n"
1251 "@code{#f}. All arrays made by @var{make-array} and\n"
1252 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1253 "@var{make-shared-array} may not be.\n\n"
1254 "If the optional argument @var{strict} is provided, a shared array will\n"
1255 "be returned only if its elements are stored internally contiguous in\n"
1257 #define FUNC_NAME s_scm_array_contents
1261 if (scm_is_generalized_vector (ra
))
1264 if (SCM_I_ARRAYP (ra
))
1266 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
1267 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
1269 for (k
= 0; k
< ndim
; k
++)
1270 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1271 if (!SCM_UNBNDP (strict
))
1273 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1275 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1277 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
1278 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1285 SCM v
= SCM_I_ARRAY_V (ra
);
1286 size_t length
= scm_c_generalized_vector_length (v
);
1287 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
1291 sra
= scm_i_make_ra (1, 0);
1292 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
1293 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1294 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
1295 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
1296 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1299 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
1300 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1302 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1308 scm_ra2contig (SCM ra
, int copy
)
1313 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1314 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1315 k
= SCM_I_ARRAY_NDIM (ra
);
1316 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1318 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1320 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1321 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1322 0 == len
% SCM_LONG_BIT
))
1325 ret
= scm_i_make_ra (k
, 0);
1326 SCM_I_ARRAY_BASE (ret
) = 0;
1329 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1330 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1331 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1332 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1334 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1336 scm_array_copy_x (ra
, ret
);
1342 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1343 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1344 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1345 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1346 "binary objects from @var{port-or-fdes}.\n"
1347 "If an end of file is encountered,\n"
1348 "the objects up to that point are put into @var{ura}\n"
1349 "(starting at the beginning) and the remainder of the array is\n"
1351 "The optional arguments @var{start} and @var{end} allow\n"
1352 "a specified region of a vector (or linearized array) to be read,\n"
1353 "leaving the remainder of the vector unchanged.\n\n"
1354 "@code{uniform-array-read!} returns the number of objects read.\n"
1355 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1356 "returned by @code{(current-input-port)}.")
1357 #define FUNC_NAME s_scm_uniform_array_read_x
1359 if (SCM_UNBNDP (port_or_fd
))
1360 port_or_fd
= scm_current_input_port ();
1362 if (scm_is_uniform_vector (ura
))
1364 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1366 else if (SCM_I_ARRAYP (ura
))
1368 size_t base
, vlen
, cstart
, cend
;
1371 cra
= scm_ra2contig (ura
, 0);
1372 base
= SCM_I_ARRAY_BASE (cra
);
1373 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1374 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1378 if (!SCM_UNBNDP (start
))
1380 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1381 if (!SCM_UNBNDP (end
))
1382 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1385 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1386 scm_from_size_t (base
+ cstart
),
1387 scm_from_size_t (base
+ cend
));
1389 if (!scm_is_eq (cra
, ura
))
1390 scm_array_copy_x (cra
, ura
);
1393 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1394 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1396 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1400 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1401 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1402 "Writes all elements of @var{ura} as binary objects to\n"
1403 "@var{port-or-fdes}.\n\n"
1404 "The optional arguments @var{start}\n"
1405 "and @var{end} allow\n"
1406 "a specified region of a vector (or linearized array) to be written.\n\n"
1407 "The number of objects actually written is returned.\n"
1408 "@var{port-or-fdes} may be\n"
1409 "omitted, in which case it defaults to the value returned by\n"
1410 "@code{(current-output-port)}.")
1411 #define FUNC_NAME s_scm_uniform_array_write
1413 if (SCM_UNBNDP (port_or_fd
))
1414 port_or_fd
= scm_current_output_port ();
1416 if (scm_is_uniform_vector (ura
))
1418 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1420 else if (SCM_I_ARRAYP (ura
))
1422 size_t base
, vlen
, cstart
, cend
;
1425 cra
= scm_ra2contig (ura
, 1);
1426 base
= SCM_I_ARRAY_BASE (cra
);
1427 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1428 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1432 if (!SCM_UNBNDP (start
))
1434 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1435 if (!SCM_UNBNDP (end
))
1436 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1439 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1440 scm_from_size_t (base
+ cstart
),
1441 scm_from_size_t (base
+ cend
));
1445 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1446 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1448 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1455 static scm_t_bits scm_tc16_bitvector
;
1457 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1458 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1459 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1462 bitvector_free (SCM vec
)
1464 scm_gc_free (BITVECTOR_BITS (vec
),
1465 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1471 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1473 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1474 size_t word_len
= (bit_len
+31)/32;
1475 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1478 scm_puts ("#*", port
);
1479 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1481 scm_t_uint32 mask
= 1;
1482 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1483 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1490 bitvector_equalp (SCM vec1
, SCM vec2
)
1492 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1493 size_t word_len
= (bit_len
+ 31) / 32;
1494 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1495 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1496 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1498 /* compare lengths */
1499 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1501 /* avoid underflow in word_len-1 below. */
1504 /* compare full words */
1505 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1507 /* compare partial last words */
1508 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1514 scm_is_bitvector (SCM vec
)
1516 return IS_BITVECTOR (vec
);
1519 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1521 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1522 "return @code{#f}.")
1523 #define FUNC_NAME s_scm_bitvector_p
1525 return scm_from_bool (scm_is_bitvector (obj
));
1530 scm_c_make_bitvector (size_t len
, SCM fill
)
1532 size_t word_len
= (len
+ 31) / 32;
1536 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1538 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1540 if (!SCM_UNBNDP (fill
))
1541 scm_bitvector_fill_x (res
, fill
);
1546 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1547 (SCM len
, SCM fill
),
1548 "Create a new bitvector of length @var{len} and\n"
1549 "optionally initialize all elements to @var{fill}.")
1550 #define FUNC_NAME s_scm_make_bitvector
1552 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1556 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1558 "Create a new bitvector with the arguments as elements.")
1559 #define FUNC_NAME s_scm_bitvector
1561 return scm_list_to_bitvector (bits
);
1566 scm_c_bitvector_length (SCM vec
)
1568 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1569 return BITVECTOR_LENGTH (vec
);
1572 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1574 "Return the length of the bitvector @var{vec}.")
1575 #define FUNC_NAME s_scm_bitvector_length
1577 return scm_from_size_t (scm_c_bitvector_length (vec
));
1581 const scm_t_uint32
*
1582 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1584 return scm_array_handle_bit_writable_elements (h
);
1588 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1591 if (SCM_I_ARRAYP (vec
))
1592 vec
= SCM_I_ARRAY_V (vec
);
1593 if (IS_BITVECTOR (vec
))
1594 return BITVECTOR_BITS (vec
) + h
->base
/32;
1595 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1599 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1601 return h
->base
% 32;
1604 const scm_t_uint32
*
1605 scm_bitvector_elements (SCM vec
,
1606 scm_t_array_handle
*h
,
1611 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1616 scm_bitvector_writable_elements (SCM vec
,
1617 scm_t_array_handle
*h
,
1622 scm_generalized_vector_get_handle (vec
, h
);
1625 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1626 *offp
= scm_array_handle_bit_elements_offset (h
);
1627 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1630 return scm_array_handle_bit_writable_elements (h
);
1634 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1636 scm_t_array_handle handle
;
1637 const scm_t_uint32
*bits
;
1639 if (IS_BITVECTOR (vec
))
1641 if (idx
>= BITVECTOR_LENGTH (vec
))
1642 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1643 bits
= BITVECTOR_BITS(vec
);
1644 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1652 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1654 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1655 idx
= idx
*inc
+ off
;
1656 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1657 scm_array_handle_release (&handle
);
1662 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1664 "Return the element at index @var{idx} of the bitvector\n"
1666 #define FUNC_NAME s_scm_bitvector_ref
1668 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1673 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1675 scm_t_array_handle handle
;
1676 scm_t_uint32
*bits
, mask
;
1678 if (IS_BITVECTOR (vec
))
1680 if (idx
>= BITVECTOR_LENGTH (vec
))
1681 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1682 bits
= BITVECTOR_BITS(vec
);
1689 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1691 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1692 idx
= idx
*inc
+ off
;
1695 mask
= 1L << (idx
%32);
1696 if (scm_is_true (val
))
1697 bits
[idx
/32] |= mask
;
1699 bits
[idx
/32] &= ~mask
;
1701 if (!IS_BITVECTOR (vec
))
1702 scm_array_handle_release (&handle
);
1705 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1706 (SCM vec
, SCM idx
, SCM val
),
1707 "Set the element at index @var{idx} of the bitvector\n"
1708 "@var{vec} when @var{val} is true, else clear it.")
1709 #define FUNC_NAME s_scm_bitvector_set_x
1711 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1712 return SCM_UNSPECIFIED
;
1716 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1718 "Set all elements of the bitvector\n"
1719 "@var{vec} when @var{val} is true, else clear them.")
1720 #define FUNC_NAME s_scm_bitvector_fill_x
1722 scm_t_array_handle handle
;
1727 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1730 if (off
== 0 && inc
== 1 && len
> 0)
1734 size_t word_len
= (len
+ 31) / 32;
1735 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1737 if (scm_is_true (val
))
1739 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1740 bits
[word_len
-1] |= last_mask
;
1744 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1745 bits
[word_len
-1] &= ~last_mask
;
1751 for (i
= 0; i
< len
; i
++)
1752 scm_array_handle_set (&handle
, i
*inc
, val
);
1755 scm_array_handle_release (&handle
);
1757 return SCM_UNSPECIFIED
;
1761 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1763 "Return a new bitvector initialized with the elements\n"
1765 #define FUNC_NAME s_scm_list_to_bitvector
1767 size_t bit_len
= scm_to_size_t (scm_length (list
));
1768 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1769 size_t word_len
= (bit_len
+31)/32;
1770 scm_t_array_handle handle
;
1771 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1775 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1777 scm_t_uint32 mask
= 1;
1779 for (j
= 0; j
< 32 && j
< bit_len
;
1780 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1781 if (scm_is_true (SCM_CAR (list
)))
1785 scm_array_handle_release (&handle
);
1791 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1793 "Return a new list initialized with the elements\n"
1794 "of the bitvector @var{vec}.")
1795 #define FUNC_NAME s_scm_bitvector_to_list
1797 scm_t_array_handle handle
;
1803 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1806 if (off
== 0 && inc
== 1)
1810 size_t word_len
= (len
+ 31) / 32;
1813 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1815 scm_t_uint32 mask
= 1;
1816 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1817 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1823 for (i
= 0; i
< len
; i
++)
1824 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1827 scm_array_handle_release (&handle
);
1829 return scm_reverse_x (res
, SCM_EOL
);
1833 /* From mmix-arith.w by Knuth.
1835 Here's a fun way to count the number of bits in a tetrabyte.
1837 [This classical trick is called the ``Gillies--Miller method for
1838 sideways addition'' in {\sl The Preparation of Programs for an
1839 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1840 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1841 the tricks used here were suggested by Balbir Singh, Peter
1842 Rossmanith, and Stefan Schwoon.]
1846 count_ones (scm_t_uint32 x
)
1848 x
=x
-((x
>>1)&0x55555555);
1849 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1850 x
=(x
+(x
>>4))&0x0f0f0f0f;
1852 return (x
+(x
>>16)) & 0xff;
1855 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1856 (SCM b
, SCM bitvector
),
1857 "Return the number of occurrences of the boolean @var{b} in\n"
1859 #define FUNC_NAME s_scm_bit_count
1861 scm_t_array_handle handle
;
1865 int bit
= scm_to_bool (b
);
1868 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1871 if (off
== 0 && inc
== 1 && len
> 0)
1875 size_t word_len
= (len
+ 31) / 32;
1876 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1879 for (i
= 0; i
< word_len
-1; i
++)
1880 count
+= count_ones (bits
[i
]);
1881 count
+= count_ones (bits
[i
] & last_mask
);
1886 for (i
= 0; i
< len
; i
++)
1887 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1891 scm_array_handle_release (&handle
);
1893 return scm_from_size_t (bit
? count
: len
-count
);
1897 /* returns 32 for x == 0.
1900 find_first_one (scm_t_uint32 x
)
1903 /* do a binary search in x. */
1904 if ((x
& 0xFFFF) == 0)
1905 x
>>= 16, pos
+= 16;
1906 if ((x
& 0xFF) == 0)
1917 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1918 (SCM item
, SCM v
, SCM k
),
1919 "Return the index of the first occurrance of @var{item} in bit\n"
1920 "vector @var{v}, starting from @var{k}. If there is no\n"
1921 "@var{item} entry between @var{k} and the end of\n"
1922 "@var{bitvector}, then return @code{#f}. For example,\n"
1925 "(bit-position #t #*000101 0) @result{} 3\n"
1926 "(bit-position #f #*0001111 3) @result{} #f\n"
1928 #define FUNC_NAME s_scm_bit_position
1930 scm_t_array_handle handle
;
1931 size_t off
, len
, first_bit
;
1933 const scm_t_uint32
*bits
;
1934 int bit
= scm_to_bool (item
);
1935 SCM res
= SCM_BOOL_F
;
1937 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1938 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1940 if (off
== 0 && inc
== 1 && len
> 0)
1942 size_t i
, word_len
= (len
+ 31) / 32;
1943 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1944 size_t first_word
= first_bit
/ 32;
1945 scm_t_uint32 first_mask
=
1946 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1949 for (i
= first_word
; i
< word_len
; i
++)
1951 w
= (bit
? bits
[i
] : ~bits
[i
]);
1952 if (i
== first_word
)
1954 if (i
== word_len
-1)
1958 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1966 for (i
= first_bit
; i
< len
; i
++)
1968 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1969 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1971 res
= scm_from_size_t (i
);
1977 scm_array_handle_release (&handle
);
1983 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1984 (SCM v
, SCM kv
, SCM obj
),
1985 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1986 "selecting the entries to change. The return value is\n"
1989 "If @var{kv} is a bit vector, then those entries where it has\n"
1990 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1991 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1992 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1993 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1996 "(define bv #*01000010)\n"
1997 "(bit-set*! bv #*10010001 #t)\n"
1999 "@result{} #*11010011\n"
2002 "If @var{kv} is a u32vector, then its elements are\n"
2003 "indices into @var{v} which are set to @var{obj}.\n"
2006 "(define bv #*01000010)\n"
2007 "(bit-set*! bv #u32(5 2 7) #t)\n"
2009 "@result{} #*01100111\n"
2011 #define FUNC_NAME s_scm_bit_set_star_x
2013 scm_t_array_handle v_handle
;
2014 size_t v_off
, v_len
;
2016 scm_t_uint32
*v_bits
;
2019 /* Validate that OBJ is a boolean so this is done even if we don't
2022 bit
= scm_to_bool (obj
);
2024 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2025 &v_off
, &v_len
, &v_inc
);
2027 if (scm_is_bitvector (kv
))
2029 scm_t_array_handle kv_handle
;
2030 size_t kv_off
, kv_len
;
2032 const scm_t_uint32
*kv_bits
;
2034 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2035 &kv_off
, &kv_len
, &kv_inc
);
2037 if (v_len
!= kv_len
)
2038 scm_misc_error (NULL
,
2039 "bit vectors must have equal length",
2042 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2044 size_t word_len
= (kv_len
+ 31) / 32;
2045 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2050 for (i
= 0; i
< word_len
-1; i
++)
2051 v_bits
[i
] &= ~kv_bits
[i
];
2052 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2056 for (i
= 0; i
< word_len
-1; i
++)
2057 v_bits
[i
] |= kv_bits
[i
];
2058 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2064 for (i
= 0; i
< kv_len
; i
++)
2065 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2066 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2069 scm_array_handle_release (&kv_handle
);
2072 else if (scm_is_true (scm_u32vector_p (kv
)))
2074 scm_t_array_handle kv_handle
;
2077 const scm_t_uint32
*kv_elts
;
2079 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2080 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2081 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2083 scm_array_handle_release (&kv_handle
);
2086 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2088 scm_array_handle_release (&v_handle
);
2090 return SCM_UNSPECIFIED
;
2095 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2096 (SCM v
, SCM kv
, SCM obj
),
2097 "Return a count of how many entries in bit vector @var{v} are\n"
2098 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2101 "If @var{kv} is a bit vector, then those entries where it has\n"
2102 "@code{#t} are the ones in @var{v} which are considered.\n"
2103 "@var{kv} and @var{v} must be the same length.\n"
2105 "If @var{kv} is a u32vector, then it contains\n"
2106 "the indexes in @var{v} to consider.\n"
2111 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2112 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2114 #define FUNC_NAME s_scm_bit_count_star
2116 scm_t_array_handle v_handle
;
2117 size_t v_off
, v_len
;
2119 const scm_t_uint32
*v_bits
;
2123 /* Validate that OBJ is a boolean so this is done even if we don't
2126 bit
= scm_to_bool (obj
);
2128 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2129 &v_off
, &v_len
, &v_inc
);
2131 if (scm_is_bitvector (kv
))
2133 scm_t_array_handle kv_handle
;
2134 size_t kv_off
, kv_len
;
2136 const scm_t_uint32
*kv_bits
;
2138 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2139 &kv_off
, &kv_len
, &kv_inc
);
2141 if (v_len
!= kv_len
)
2142 scm_misc_error (NULL
,
2143 "bit vectors must have equal length",
2146 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2148 size_t i
, word_len
= (kv_len
+ 31) / 32;
2149 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2150 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2152 for (i
= 0; i
< word_len
-1; i
++)
2153 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2154 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2159 for (i
= 0; i
< kv_len
; i
++)
2160 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2162 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2163 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2168 scm_array_handle_release (&kv_handle
);
2171 else if (scm_is_true (scm_u32vector_p (kv
)))
2173 scm_t_array_handle kv_handle
;
2176 const scm_t_uint32
*kv_elts
;
2178 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2179 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2181 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2182 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2186 scm_array_handle_release (&kv_handle
);
2189 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2191 scm_array_handle_release (&v_handle
);
2193 return scm_from_size_t (count
);
2197 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2199 "Modify the bit vector @var{v} by replacing each element with\n"
2201 #define FUNC_NAME s_scm_bit_invert_x
2203 scm_t_array_handle handle
;
2208 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2210 if (off
== 0 && inc
== 1 && len
> 0)
2212 size_t word_len
= (len
+ 31) / 32;
2213 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2216 for (i
= 0; i
< word_len
-1; i
++)
2218 bits
[i
] = bits
[i
] ^ last_mask
;
2223 for (i
= 0; i
< len
; i
++)
2224 scm_array_handle_set (&handle
, i
*inc
,
2225 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2228 scm_array_handle_release (&handle
);
2230 return SCM_UNSPECIFIED
;
2236 scm_istr2bve (SCM str
)
2238 scm_t_array_handle handle
;
2239 size_t len
= scm_i_string_length (str
);
2240 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2248 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2249 c_str
= scm_i_string_chars (str
);
2251 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2257 for (mask
= 1L; j
--; mask
<<= 1)
2272 scm_array_handle_release (&handle
);
2273 scm_remember_upto_here_1 (str
);
2280 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2285 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2287 if (k
== SCM_I_ARRAY_NDIM (ra
))
2288 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2290 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2291 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2293 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2297 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2304 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2306 "Return a list consisting of all the elements, in order, of\n"
2308 #define FUNC_NAME s_scm_array_to_list
2310 if (scm_is_generalized_vector (v
))
2311 return scm_generalized_vector_to_list (v
);
2312 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2313 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2315 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2320 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2322 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2323 (SCM type
, SCM shape
, SCM lst
),
2324 "Return an array of the type @var{type}\n"
2325 "with elements the same as those of @var{lst}.\n"
2327 "The argument @var{shape} determines the number of dimensions\n"
2328 "of the array and their shape. It is either an exact integer,\n"
2330 "number of dimensions directly, or a list whose length\n"
2331 "specifies the number of dimensions and each element specified\n"
2332 "the lower and optionally the upper bound of the corresponding\n"
2334 "When the element is list of two elements, these elements\n"
2335 "give the lower and upper bounds. When it is an exact\n"
2336 "integer, it gives only the lower bound.")
2337 #define FUNC_NAME s_scm_list_to_typed_array
2341 scm_t_array_handle handle
;
2344 if (scm_is_integer (shape
))
2346 size_t k
= scm_to_size_t (shape
);
2350 shape
= scm_cons (scm_length (row
), shape
);
2351 if (k
> 0 && !scm_is_null (row
))
2352 row
= scm_car (row
);
2357 SCM shape_spec
= shape
;
2361 SCM spec
= scm_car (shape_spec
);
2362 if (scm_is_pair (spec
))
2363 shape
= scm_cons (spec
, shape
);
2365 shape
= scm_cons (scm_list_2 (spec
,
2366 scm_sum (scm_sum (spec
,
2368 scm_from_int (-1))),
2370 shape_spec
= scm_cdr (shape_spec
);
2371 if (scm_is_pair (shape_spec
))
2373 if (!scm_is_null (row
))
2374 row
= scm_car (row
);
2381 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2382 scm_reverse_x (shape
, SCM_EOL
));
2384 scm_array_get_handle (ra
, &handle
);
2385 l2ra (lst
, &handle
, 0, 0);
2386 scm_array_handle_release (&handle
);
2392 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2393 (SCM ndim
, SCM lst
),
2394 "Return an array with elements the same as those of @var{lst}.")
2395 #define FUNC_NAME s_scm_list_to_array
2397 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2402 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2404 if (k
== scm_array_handle_rank (handle
))
2405 scm_array_handle_set (handle
, pos
, lst
);
2408 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2409 ssize_t inc
= dim
->inc
;
2410 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2411 char *errmsg
= NULL
;
2414 while (n
> 0 && scm_is_pair (lst
))
2416 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2418 lst
= SCM_CDR (lst
);
2422 errmsg
= "too few elements for array dimension ~a, need ~a";
2423 if (!scm_is_null (lst
))
2424 errmsg
= "too many elements for array dimension ~a, want ~a";
2426 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2427 scm_from_size_t (len
)));
2431 #if SCM_ENABLE_DEPRECATED
2433 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2434 (SCM ndim
, SCM prot
, SCM lst
),
2435 "Return a uniform array of the type indicated by prototype\n"
2436 "@var{prot} with elements the same as those of @var{lst}.\n"
2437 "Elements must be of the appropriate type, no coercions are\n"
2440 "The argument @var{ndim} determines the number of dimensions\n"
2441 "of the array. It is either an exact integer, giving the\n"
2442 "number directly, or a list of exact integers, whose length\n"
2443 "specifies the number of dimensions and each element is the\n"
2444 "lower index bound of its dimension.")
2445 #define FUNC_NAME s_scm_list_to_uniform_array
2447 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2453 /* Print dimension DIM of ARRAY.
2457 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2458 SCM port
, scm_print_state
*pstate
)
2460 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2463 scm_putc ('(', port
);
2465 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2467 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2468 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2471 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2473 if (idx
< dim_spec
->ubnd
)
2474 scm_putc (' ', port
);
2475 base
+= dim_spec
->inc
;
2478 scm_putc (')', port
);
2482 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2486 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2488 long ndim
= SCM_I_ARRAY_NDIM (array
);
2489 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2490 SCM v
= SCM_I_ARRAY_V (array
);
2491 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2493 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2495 scm_putc ('#', port
);
2496 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2497 scm_intprint (ndim
, 10, port
);
2498 if (scm_is_uniform_vector (v
))
2499 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2500 else if (scm_is_bitvector (v
))
2501 scm_puts ("b", port
);
2502 else if (scm_is_string (v
))
2503 scm_puts ("a", port
);
2504 else if (!scm_is_vector (v
))
2505 scm_puts ("?", port
);
2507 for (i
= 0; i
< ndim
; i
++)
2509 if (dim_specs
[i
].lbnd
!= 0)
2511 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2517 if (print_lbnds
|| print_lens
)
2518 for (i
= 0; i
< ndim
; i
++)
2522 scm_putc ('@', port
);
2523 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2527 scm_putc (':', port
);
2528 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2535 /* Rank zero arrays, which are really just scalars, are printed
2536 specially. The consequent way would be to print them as
2540 where OBJ is the printed representation of the scalar, but we
2541 print them instead as
2545 to make them look less strange.
2547 Just printing them as
2551 would be correct in a way as well, but zero rank arrays are
2552 not really the same as Scheme values since they are boxed and
2553 can be modified with array-set!, say.
2555 scm_putc ('(', port
);
2556 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2557 scm_putc (')', port
);
2561 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2565 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2569 scm_putc ('#', port
);
2570 base
= SCM_I_ARRAY_BASE (array
);
2571 scm_puts ("<enclosed-array ", port
);
2572 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2573 scm_putc ('>', port
);
2577 /* Read an array. This function can also read vectors and uniform
2578 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2581 C is the first character read after the '#'.
2585 tag_to_type (const char *tag
, SCM port
)
2587 #if SCM_ENABLE_DEPRECATED
2589 /* Recognize the old syntax.
2591 const char *instead
;
2623 if (instead
&& tag
[1] == '\0')
2625 scm_c_issue_deprecation_warning_fmt
2626 ("The tag '%c' is deprecated for uniform vectors. "
2627 "Use '%s' instead.", tag
[0], instead
);
2628 return scm_from_locale_symbol (instead
);
2636 return scm_from_locale_symbol (tag
);
2640 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2649 c
= scm_getc (port
);
2652 while ('0' <= c
&& c
<= '9')
2654 res
= 10*res
+ c
-'0';
2656 c
= scm_getc (port
);
2665 scm_i_read_array (SCM port
, int c
)
2672 SCM shape
= SCM_BOOL_F
, elements
;
2674 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2675 the array code can not deal with zero-length dimensions yet, and
2676 we want to allow zero-length vectors, of course.
2680 scm_ungetc (c
, port
);
2681 return scm_vector (scm_read (port
));
2684 /* Disambiguate between '#f' and uniform floating point vectors.
2688 c
= scm_getc (port
);
2689 if (c
!= '3' && c
!= '6')
2692 scm_ungetc (c
, port
);
2699 goto continue_reading_tag
;
2705 c
= read_decimal_integer (port
, c
, &rank
);
2707 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2713 continue_reading_tag
:
2714 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2717 c
= scm_getc (port
);
2719 tag
[tag_len
] = '\0';
2723 if (c
== '@' || c
== ':')
2729 ssize_t lbnd
= 0, len
= 0;
2734 c
= scm_getc (port
);
2735 c
= read_decimal_integer (port
, c
, &lbnd
);
2738 s
= scm_from_ssize_t (lbnd
);
2742 c
= scm_getc (port
);
2743 c
= read_decimal_integer (port
, c
, &len
);
2744 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2747 shape
= scm_cons (s
, shape
);
2748 } while (c
== '@' || c
== ':');
2750 shape
= scm_reverse_x (shape
, SCM_EOL
);
2753 /* Read nested lists of elements.
2756 scm_i_input_error (NULL
, port
,
2757 "missing '(' in vector or array literal",
2759 scm_ungetc (c
, port
);
2760 elements
= scm_read (port
);
2762 if (scm_is_false (shape
))
2763 shape
= scm_from_ssize_t (rank
);
2764 else if (scm_ilength (shape
) != rank
)
2767 "the number of shape specifications must match the array rank",
2770 /* Handle special print syntax of rank zero arrays; see
2771 scm_i_print_array for a rationale.
2775 if (!scm_is_pair (elements
))
2776 scm_i_input_error (NULL
, port
,
2777 "too few elements in array literal, need 1",
2779 if (!scm_is_null (SCM_CDR (elements
)))
2780 scm_i_input_error (NULL
, port
,
2781 "too many elements in array literal, want 1",
2783 elements
= SCM_CAR (elements
);
2788 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2791 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2794 #define FUNC_NAME s_scm_array_type
2796 if (SCM_I_ARRAYP (ra
))
2797 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2798 else if (scm_is_generalized_vector (ra
))
2799 return scm_i_generalized_vector_type (ra
);
2800 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2801 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2803 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2807 #if SCM_ENABLE_DEPRECATED
2809 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2811 "Return an object that would produce an array of the same type\n"
2812 "as @var{array}, if used as the @var{prototype} for\n"
2813 "@code{make-uniform-array}.")
2814 #define FUNC_NAME s_scm_array_prototype
2816 if (SCM_I_ARRAYP (ra
))
2817 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2818 else if (scm_is_generalized_vector (ra
))
2819 return scm_i_get_old_prototype (ra
);
2820 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2821 return SCM_UNSPECIFIED
;
2823 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2830 array_mark (SCM ptr
)
2832 return SCM_I_ARRAY_V (ptr
);
2836 array_free (SCM ptr
)
2838 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
2839 (sizeof (scm_i_t_array
)
2840 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2845 #if SCM_ENABLE_DEPRECATED
2848 scm_make_ra (int ndim
)
2850 scm_c_issue_deprecation_warning
2851 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2852 return scm_i_make_ra (ndim
, 0);
2856 scm_shap2ra (SCM args
, const char *what
)
2858 scm_c_issue_deprecation_warning
2859 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2860 return scm_i_shap2ra (args
);
2864 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2866 scm_c_issue_deprecation_warning
2867 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2868 return scm_c_generalized_vector_ref (v
, pos
);
2872 scm_ra_set_contp (SCM ra
)
2874 scm_c_issue_deprecation_warning
2875 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2876 scm_i_ra_set_contp (ra
);
2880 scm_aind (SCM ra
, SCM args
, const char *what
)
2882 scm_t_array_handle handle
;
2885 scm_c_issue_deprecation_warning
2886 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2888 if (scm_is_integer (args
))
2889 args
= scm_list_1 (args
);
2891 scm_array_get_handle (ra
, &handle
);
2892 pos
= scm_array_handle_pos (&handle
, args
) + SCM_I_ARRAY_BASE (ra
);
2893 scm_array_handle_release (&handle
);
2898 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2900 scm_c_issue_deprecation_warning
2901 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2903 scm_iprin1 (exp
, port
, pstate
);
2912 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2913 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
2914 scm_set_smob_free (scm_i_tc16_array
, array_free
);
2915 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2916 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2918 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2919 scm_set_smob_mark (scm_i_tc16_enclosed_array
, array_mark
);
2920 scm_set_smob_free (scm_i_tc16_enclosed_array
, array_free
);
2921 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2922 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2924 scm_add_feature ("array");
2926 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2927 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2928 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2929 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2931 init_type_creator_table ();
2933 #include "libguile/unif.x"