1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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");
152 prototype_to_type (SCM proto
)
154 const char *type_name
;
156 if (scm_is_eq (proto
, SCM_BOOL_T
))
158 else if (scm_is_eq (proto
, SCM_MAKE_CHAR ('a')))
160 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
162 else if (scm_is_eq (proto
, scm_sym_s
))
164 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (1))))
166 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (-1))))
168 else if (scm_is_eq (proto
, scm_sym_l
))
170 else if (scm_is_true (scm_eqv_p (proto
, scm_from_double (1.0))))
172 else if (scm_is_true (scm_eqv_p (proto
, scm_divide (scm_from_int (1),
175 else if (scm_is_true (scm_eqv_p (proto
, scm_c_make_rectangular (0, 1))))
177 else if (scm_is_null (proto
))
183 return scm_from_locale_symbol (type_name
);
189 scm_i_get_old_prototype (SCM uvec
)
191 if (scm_is_bitvector (uvec
))
193 else if (scm_is_string (uvec
))
194 return SCM_MAKE_CHAR ('a');
195 else if (scm_is_true (scm_s8vector_p (uvec
)))
196 return SCM_MAKE_CHAR ('\0');
197 else if (scm_is_true (scm_s16vector_p (uvec
)))
199 else if (scm_is_true (scm_u32vector_p (uvec
)))
200 return scm_from_int (1);
201 else if (scm_is_true (scm_s32vector_p (uvec
)))
202 return scm_from_int (-1);
203 else if (scm_is_true (scm_s64vector_p (uvec
)))
205 else if (scm_is_true (scm_f32vector_p (uvec
)))
206 return scm_from_double (1.0);
207 else if (scm_is_true (scm_f64vector_p (uvec
)))
208 return scm_divide (scm_from_int (1), scm_from_int (3));
209 else if (scm_is_true (scm_c64vector_p (uvec
)))
210 return scm_c_make_rectangular (0, 1);
211 else if (scm_is_vector (uvec
))
214 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
218 scm_make_uve (long k
, SCM prot
)
219 #define FUNC_NAME "scm_make_uve"
221 scm_c_issue_deprecation_warning
222 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
224 return make_typed_vector (prototype_to_type (prot
), k
);
231 scm_is_array (SCM obj
)
233 return (SCM_I_ENCLOSED_ARRAYP (obj
)
234 || SCM_I_ARRAYP (obj
)
235 || scm_is_generalized_vector (obj
));
239 scm_is_typed_array (SCM obj
, SCM type
)
241 if (SCM_I_ENCLOSED_ARRAYP (obj
))
243 /* Enclosed arrays are arrays but are not of any type.
248 /* Get storage vector.
250 if (SCM_I_ARRAYP (obj
))
251 obj
= SCM_I_ARRAY_V (obj
);
253 /* It must be a generalized vector (which includes vectors, strings, etc).
255 if (!scm_is_generalized_vector (obj
))
258 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
262 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
264 return scm_i_cvref (SCM_I_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
268 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
270 return ((const SCM
*)h
->elements
)[pos
];
274 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
277 if (SCM_I_ARRAYP (h
->array
))
278 return scm_c_string_ref (SCM_I_ARRAY_V (h
->array
), pos
);
280 return scm_c_string_ref (h
->array
, pos
);
284 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
286 pos
+= scm_array_handle_bit_elements_offset (h
);
288 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
292 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
296 if (SCM_I_ENCLOSED_ARRAYP (v
))
298 h
->ref
= enclosed_ref
;
299 return enclosed_ref (h
, pos
);
302 if (SCM_I_ARRAYP (v
))
303 v
= SCM_I_ARRAY_V (v
);
305 if (scm_is_vector (v
))
307 h
->elements
= scm_array_handle_elements (h
);
310 else if (scm_is_uniform_vector (v
))
312 h
->elements
= scm_array_handle_uniform_elements (h
);
313 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
315 else if (scm_is_string (v
))
319 else if (scm_is_bitvector (v
))
321 h
->elements
= scm_array_handle_bit_elements (h
);
322 h
->ref
= bitvector_ref
;
325 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
327 return h
->ref (h
, pos
);
331 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
333 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
337 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
339 ((SCM
*)h
->writable_elements
)[pos
] = val
;
343 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
346 if (SCM_I_ARRAYP (h
->array
))
347 return scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
349 return scm_c_string_set_x (h
->array
, pos
, val
);
353 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
356 pos
+= scm_array_handle_bit_elements_offset (h
);
357 mask
= 1l << (pos
% 32);
358 if (scm_to_bool (val
))
359 ((scm_t_uint32
*)h
->elements
)[pos
/32] |= mask
;
361 ((scm_t_uint32
*)h
->elements
)[pos
/32] &= ~mask
;
365 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
369 if (SCM_I_ENCLOSED_ARRAYP (v
))
371 h
->set
= enclosed_set
;
372 enclosed_set (h
, pos
, val
);
376 if (SCM_I_ARRAYP (v
))
377 v
= SCM_I_ARRAY_V (v
);
379 if (scm_is_vector (v
))
381 h
->writable_elements
= scm_array_handle_writable_elements (h
);
384 else if (scm_is_uniform_vector (v
))
386 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
387 h
->set
= scm_i_uniform_vector_set_proc (v
);
389 else if (scm_is_string (v
))
393 else if (scm_is_bitvector (v
))
395 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
396 h
->set
= bitvector_set
;
399 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
401 h
->set (h
, pos
, val
);
405 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
408 h
->ref
= memoize_ref
;
409 h
->set
= memoize_set
;
411 if (SCM_I_ARRAYP (array
) || SCM_I_ENCLOSED_ARRAYP (array
))
413 h
->dims
= SCM_I_ARRAY_DIMS (array
);
414 h
->base
= SCM_I_ARRAY_BASE (array
);
416 else if (scm_is_generalized_vector (array
))
419 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
425 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
429 scm_array_handle_release (scm_t_array_handle
*h
)
431 /* Nothing to do here until arrays need to be reserved for real.
436 scm_array_handle_rank (scm_t_array_handle
*h
)
438 if (SCM_I_ARRAYP (h
->array
) || SCM_I_ENCLOSED_ARRAYP (h
->array
))
439 return SCM_I_ARRAY_NDIM (h
->array
);
445 scm_array_handle_dims (scm_t_array_handle
*h
)
451 scm_array_handle_elements (scm_t_array_handle
*h
)
454 if (SCM_I_ARRAYP (vec
))
455 vec
= SCM_I_ARRAY_V (vec
);
456 if (SCM_I_IS_VECTOR (vec
))
457 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
458 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
462 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
465 if (SCM_I_ARRAYP (vec
))
466 vec
= SCM_I_ARRAY_V (vec
);
467 if (SCM_I_IS_VECTOR (vec
))
468 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
469 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
472 #if SCM_ENABLE_DEPRECATED
474 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
476 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
478 #define FUNC_NAME s_scm_array_p
480 if (!SCM_UNBNDP (prot
))
482 scm_c_issue_deprecation_warning
483 ("Using prototypes with `array?' is deprecated."
484 " Use `typed-array?' instead.");
486 return scm_typed_array_p (obj
, prototype_to_type (prot
));
489 return scm_from_bool (scm_is_array (obj
));
493 #else /* !SCM_ENABLE_DEPRECATED */
495 /* We keep the old 2-argument C prototype for a while although the old
496 PROT argument is always ignored now. C code should probably use
497 scm_is_array or scm_is_typed_array anyway.
500 static SCM
scm_i_array_p (SCM obj
);
502 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
504 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
506 #define FUNC_NAME s_scm_i_array_p
508 return scm_from_bool (scm_is_array (obj
));
513 scm_array_p (SCM obj
, SCM prot
)
515 return scm_from_bool (scm_is_array (obj
));
518 #endif /* !SCM_ENABLE_DEPRECATED */
521 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
523 "Return @code{#t} if the @var{obj} is an array of type\n"
524 "@var{type}, and @code{#f} if not.")
525 #define FUNC_NAME s_scm_typed_array_p
527 return scm_from_bool (scm_is_typed_array (obj
, type
));
532 scm_c_array_rank (SCM array
)
534 scm_t_array_handle handle
;
537 scm_array_get_handle (array
, &handle
);
538 res
= scm_array_handle_rank (&handle
);
539 scm_array_handle_release (&handle
);
543 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
545 "Return the number of dimensions of the array @var{array.}\n")
546 #define FUNC_NAME s_scm_array_rank
548 return scm_from_size_t (scm_c_array_rank (array
));
553 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
555 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
556 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
558 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
560 #define FUNC_NAME s_scm_array_dimensions
562 scm_t_array_handle handle
;
567 scm_array_get_handle (ra
, &handle
);
568 s
= scm_array_handle_dims (&handle
);
569 k
= scm_array_handle_rank (&handle
);
572 res
= scm_cons (s
[k
].lbnd
573 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
574 scm_from_ssize_t (s
[k
].ubnd
),
576 : scm_from_ssize_t (1 + s
[k
].ubnd
),
579 scm_array_handle_release (&handle
);
585 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
587 "Return the root vector of a shared array.")
588 #define FUNC_NAME s_scm_shared_array_root
590 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
591 return SCM_I_ARRAY_V (ra
);
592 else if (scm_is_generalized_vector (ra
))
594 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
599 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
601 "Return the root vector index of the first element in the array.")
602 #define FUNC_NAME s_scm_shared_array_offset
604 scm_t_array_handle handle
;
607 scm_array_get_handle (ra
, &handle
);
608 res
= scm_from_size_t (handle
.base
);
609 scm_array_handle_release (&handle
);
615 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
617 "For each dimension, return the distance between elements in the root vector.")
618 #define FUNC_NAME s_scm_shared_array_increments
620 scm_t_array_handle handle
;
625 scm_array_get_handle (ra
, &handle
);
626 k
= scm_array_handle_rank (&handle
);
627 s
= scm_array_handle_dims (&handle
);
629 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
630 scm_array_handle_release (&handle
);
636 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
638 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
640 size_t k
= scm_array_handle_rank (h
);
642 while (k
> 0 && scm_is_pair (indices
))
644 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
645 pos
+= (i
- s
->lbnd
) * s
->inc
;
648 indices
= SCM_CDR (indices
);
650 if (k
> 0 || !scm_is_null (indices
))
651 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
652 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
657 scm_i_make_ra (int ndim
, int enclosed
)
659 scm_t_bits tag
= enclosed
? scm_i_tc16_enclosed_array
: scm_i_tc16_array
;
661 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
662 scm_gc_malloc ((sizeof (scm_i_t_array
) +
663 ndim
* sizeof (scm_t_array_dim
)),
665 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
669 static char s_bad_spec
[] = "Bad scm_array dimension";
672 /* Increments will still need to be set. */
675 scm_i_shap2ra (SCM args
)
679 int ndim
= scm_ilength (args
);
681 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
683 ra
= scm_i_make_ra (ndim
, 0);
684 SCM_I_ARRAY_BASE (ra
) = 0;
685 s
= SCM_I_ARRAY_DIMS (ra
);
686 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
688 spec
= SCM_CAR (args
);
689 if (scm_is_integer (spec
))
691 if (scm_to_long (spec
) < 0)
692 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
694 s
->ubnd
= scm_to_long (spec
) - 1;
699 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
700 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
701 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
703 if (!scm_is_pair (sp
)
704 || !scm_is_integer (SCM_CAR (sp
))
705 || !scm_is_null (SCM_CDR (sp
)))
706 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
707 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
714 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
715 (SCM type
, SCM fill
, SCM bounds
),
716 "Create and return an array of type @var{type}.")
717 #define FUNC_NAME s_scm_make_typed_array
721 creator_proc
*creator
;
724 creator
= type_to_creator (type
);
725 ra
= scm_i_shap2ra (bounds
);
726 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
727 s
= SCM_I_ARRAY_DIMS (ra
);
728 k
= SCM_I_ARRAY_NDIM (ra
);
733 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
734 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
737 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
738 fill
= SCM_UNDEFINED
;
740 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
742 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
743 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
744 return SCM_I_ARRAY_V (ra
);
749 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
750 (SCM fill
, SCM bounds
),
751 "Create and return an array.")
752 #define FUNC_NAME s_scm_make_array
754 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
758 #if SCM_ENABLE_DEPRECATED
760 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
761 (SCM dims
, SCM prot
, SCM fill
),
762 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
763 "Create and return a uniform array or vector of type\n"
764 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
765 "length @var{length}. If @var{fill} is supplied, it's used to\n"
766 "fill the array, otherwise @var{prototype} is used.")
767 #define FUNC_NAME s_scm_dimensions_to_uniform_array
769 scm_c_issue_deprecation_warning
770 ("`dimensions->uniform-array' is deprecated. "
771 "Use `make-typed-array' instead.");
773 if (scm_is_integer (dims
))
774 dims
= scm_list_1 (dims
);
775 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
782 scm_i_ra_set_contp (SCM ra
)
784 size_t k
= SCM_I_ARRAY_NDIM (ra
);
787 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
790 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
792 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
795 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
796 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
799 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
803 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
804 (SCM oldra
, SCM mapfunc
, SCM dims
),
805 "@code{make-shared-array} can be used to create shared subarrays of other\n"
806 "arrays. The @var{mapper} is a function that translates coordinates in\n"
807 "the new array into coordinates in the old array. A @var{mapper} must be\n"
808 "linear, and its range must stay within the bounds of the old array, but\n"
809 "it can be otherwise arbitrary. A simple example:\n"
811 "(define fred (make-array #f 8 8))\n"
812 "(define freds-diagonal\n"
813 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
814 "(array-set! freds-diagonal 'foo 3)\n"
815 "(array-ref fred 3 3) @result{} foo\n"
816 "(define freds-center\n"
817 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
818 "(array-ref freds-center 0 0) @result{} foo\n"
820 #define FUNC_NAME s_scm_make_shared_array
822 scm_t_array_handle old_handle
;
828 long old_min
, new_min
, old_max
, new_max
;
831 SCM_VALIDATE_REST_ARGUMENT (dims
);
832 SCM_VALIDATE_PROC (2, mapfunc
);
833 ra
= scm_i_shap2ra (dims
);
835 scm_array_get_handle (oldra
, &old_handle
);
837 if (SCM_I_ARRAYP (oldra
))
839 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
840 old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
841 s
= scm_array_handle_dims (&old_handle
);
842 k
= scm_array_handle_rank (&old_handle
);
846 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
848 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
853 SCM_I_ARRAY_V (ra
) = oldra
;
855 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
859 s
= SCM_I_ARRAY_DIMS (ra
);
860 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
862 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
863 if (s
[k
].ubnd
< s
[k
].lbnd
)
865 if (1 == SCM_I_ARRAY_NDIM (ra
))
866 ra
= make_typed_vector (scm_array_type (ra
), 0);
868 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
869 scm_array_handle_release (&old_handle
);
874 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
875 i
= scm_array_handle_pos (&old_handle
, imap
);
876 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
878 k
= SCM_I_ARRAY_NDIM (ra
);
881 if (s
[k
].ubnd
> s
[k
].lbnd
)
883 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
884 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
885 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
888 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
890 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
893 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
894 indptr
= SCM_CDR (indptr
);
897 scm_array_handle_release (&old_handle
);
899 if (old_min
> new_min
|| old_max
< new_max
)
900 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
901 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
903 SCM v
= SCM_I_ARRAY_V (ra
);
904 size_t length
= scm_c_generalized_vector_length (v
);
905 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
907 if (s
->ubnd
< s
->lbnd
)
908 return make_typed_vector (scm_array_type (ra
), 0);
910 scm_i_ra_set_contp (ra
);
916 /* args are RA . DIMS */
917 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
919 "Return an array sharing contents with @var{array}, but with\n"
920 "dimensions arranged in a different order. There must be one\n"
921 "@var{dim} argument for each dimension of @var{array}.\n"
922 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
923 "and the rank of the array to be returned. Each integer in that\n"
924 "range must appear at least once in the argument list.\n"
926 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
927 "dimensions in the array to be returned, their positions in the\n"
928 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
929 "may have the same value, in which case the returned array will\n"
930 "have smaller rank than @var{array}.\n"
933 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
934 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
935 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
936 " #2((a 4) (b 5) (c 6))\n"
938 #define FUNC_NAME s_scm_transpose_array
941 scm_t_array_dim
*s
, *r
;
944 SCM_VALIDATE_REST_ARGUMENT (args
);
945 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
947 if (scm_is_generalized_vector (ra
))
949 /* Make sure that we are called with a single zero as
952 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
953 SCM_WRONG_NUM_ARGS ();
954 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
955 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
959 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
961 vargs
= scm_vector (args
);
962 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
963 SCM_WRONG_NUM_ARGS ();
965 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
967 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
968 0, SCM_I_ARRAY_NDIM(ra
));
973 res
= scm_i_make_ra (ndim
, 0);
974 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
975 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
978 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
979 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
981 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
983 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
984 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
985 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
986 if (r
->ubnd
< r
->lbnd
)
995 if (r
->ubnd
> s
->ubnd
)
997 if (r
->lbnd
< s
->lbnd
)
999 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1006 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1007 scm_i_ra_set_contp (res
);
1011 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1015 /* args are RA . AXES */
1016 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1018 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1019 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1020 "resembling an array of shared arrays. The dimensions of each shared\n"
1021 "array are the same as the @var{dim}th dimensions of the original array,\n"
1022 "the dimensions of the outer array are the same as those of the original\n"
1023 "array that did not match a @var{dim}.\n\n"
1024 "An enclosed array is not a general Scheme array. Its elements may not\n"
1025 "be set using @code{array-set!}. Two references to the same element of\n"
1026 "an enclosed array will be @code{equal?} but will not in general be\n"
1027 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1028 "enclosed array is unspecified.\n\n"
1031 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1032 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1033 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1034 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1036 #define FUNC_NAME s_scm_enclose_array
1038 SCM axv
, res
, ra_inr
;
1040 scm_t_array_dim vdim
, *s
= &vdim
;
1041 int ndim
, j
, k
, ninr
, noutr
;
1043 SCM_VALIDATE_REST_ARGUMENT (axes
);
1044 if (scm_is_null (axes
))
1045 axes
= scm_cons ((SCM_I_ARRAYP (ra
) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1046 ninr
= scm_ilength (axes
);
1048 SCM_WRONG_NUM_ARGS ();
1049 ra_inr
= scm_i_make_ra (ninr
, 0);
1051 if (scm_is_generalized_vector (ra
))
1054 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1056 SCM_I_ARRAY_V (ra_inr
) = ra
;
1057 SCM_I_ARRAY_BASE (ra_inr
) = 0;
1060 else if (SCM_I_ARRAYP (ra
))
1062 s
= SCM_I_ARRAY_DIMS (ra
);
1063 SCM_I_ARRAY_V (ra_inr
) = SCM_I_ARRAY_V (ra
);
1064 SCM_I_ARRAY_BASE (ra_inr
) = SCM_I_ARRAY_BASE (ra
);
1065 ndim
= SCM_I_ARRAY_NDIM (ra
);
1068 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1070 noutr
= ndim
- ninr
;
1072 SCM_WRONG_NUM_ARGS ();
1073 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1074 res
= scm_i_make_ra (noutr
, 1);
1075 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra_inr
);
1076 SCM_I_ARRAY_V (res
) = ra_inr
;
1077 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1079 if (!scm_is_integer (SCM_CAR (axes
)))
1080 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1081 j
= scm_to_int (SCM_CAR (axes
));
1082 SCM_I_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1083 SCM_I_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1084 SCM_I_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1085 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1087 c_axv
= scm_i_string_chars (axv
);
1088 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1092 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1093 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1094 SCM_I_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1096 scm_remember_upto_here_1 (axv
);
1097 scm_i_ra_set_contp (ra_inr
);
1098 scm_i_ra_set_contp (res
);
1105 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1107 "Return @code{#t} if its arguments would be acceptable to\n"
1108 "@code{array-ref}.")
1109 #define FUNC_NAME s_scm_array_in_bounds_p
1111 SCM res
= SCM_BOOL_T
;
1113 SCM_VALIDATE_REST_ARGUMENT (args
);
1115 if (scm_is_generalized_vector (v
))
1119 if (!scm_is_pair (args
))
1120 SCM_WRONG_NUM_ARGS ();
1121 ind
= scm_to_long (SCM_CAR (args
));
1122 args
= SCM_CDR (args
);
1123 res
= scm_from_bool (ind
>= 0
1124 && ind
< scm_c_generalized_vector_length (v
));
1126 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
1128 size_t k
= SCM_I_ARRAY_NDIM (v
);
1129 scm_t_array_dim
*s
= SCM_I_ARRAY_DIMS (v
);
1135 if (!scm_is_pair (args
))
1136 SCM_WRONG_NUM_ARGS ();
1137 ind
= scm_to_long (SCM_CAR (args
));
1138 args
= SCM_CDR (args
);
1141 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1144 /* We do not stop the checking after finding a violation
1145 since we want to validate the type-correctness and
1146 number of arguments in any case.
1152 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1154 if (!scm_is_null (args
))
1155 SCM_WRONG_NUM_ARGS ();
1162 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1166 int k
= SCM_I_ARRAY_NDIM (v
);
1167 SCM res
= scm_i_make_ra (k
, 0);
1168 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (v
);
1169 SCM_I_ARRAY_BASE (res
) = pos
;
1172 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= SCM_I_ARRAY_DIMS (v
)[k
].ubnd
;
1173 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= SCM_I_ARRAY_DIMS (v
)[k
].lbnd
;
1174 SCM_I_ARRAY_DIMS (res
)[k
].inc
= SCM_I_ARRAY_DIMS (v
)[k
].inc
;
1179 return scm_c_generalized_vector_ref (v
, pos
);
1182 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1184 "Return the element at the @code{(index1, index2)} element in\n"
1186 #define FUNC_NAME s_scm_array_ref
1188 scm_t_array_handle handle
;
1191 scm_array_get_handle (v
, &handle
);
1192 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
1193 scm_array_handle_release (&handle
);
1199 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1200 (SCM v
, SCM obj
, SCM args
),
1201 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1202 "@var{new-value}. The value returned by array-set! is unspecified.")
1203 #define FUNC_NAME s_scm_array_set_x
1205 scm_t_array_handle handle
;
1207 scm_array_get_handle (v
, &handle
);
1208 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
1209 scm_array_handle_release (&handle
);
1210 return SCM_UNSPECIFIED
;
1214 /* attempts to unroll an array into a one-dimensional array.
1215 returns the unrolled array or #f if it can't be done. */
1216 /* if strict is not SCM_UNDEFINED, return #f if returned array
1217 wouldn't have contiguous elements. */
1218 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1219 (SCM ra
, SCM strict
),
1220 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1221 "without changing their order (last subscript changing fastest), then\n"
1222 "@code{array-contents} returns that shared array, otherwise it returns\n"
1223 "@code{#f}. All arrays made by @var{make-array} and\n"
1224 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1225 "@var{make-shared-array} may not be.\n\n"
1226 "If the optional argument @var{strict} is provided, a shared array will\n"
1227 "be returned only if its elements are stored internally contiguous in\n"
1229 #define FUNC_NAME s_scm_array_contents
1233 if (scm_is_generalized_vector (ra
))
1236 if (SCM_I_ARRAYP (ra
))
1238 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
1239 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
1241 for (k
= 0; k
< ndim
; k
++)
1242 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1243 if (!SCM_UNBNDP (strict
))
1245 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1247 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1249 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
1250 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1257 SCM v
= SCM_I_ARRAY_V (ra
);
1258 size_t length
= scm_c_generalized_vector_length (v
);
1259 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
1263 sra
= scm_i_make_ra (1, 0);
1264 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
1265 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1266 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
1267 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
1268 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1271 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
1272 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1274 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1280 scm_ra2contig (SCM ra
, int copy
)
1285 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1286 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1287 k
= SCM_I_ARRAY_NDIM (ra
);
1288 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1290 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1292 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1293 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1294 0 == len
% SCM_LONG_BIT
))
1297 ret
= scm_i_make_ra (k
, 0);
1298 SCM_I_ARRAY_BASE (ret
) = 0;
1301 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1302 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1303 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1304 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1306 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1308 scm_array_copy_x (ra
, ret
);
1314 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1315 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1316 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1317 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1318 "binary objects from @var{port-or-fdes}.\n"
1319 "If an end of file is encountered,\n"
1320 "the objects up to that point are put into @var{ura}\n"
1321 "(starting at the beginning) and the remainder of the array is\n"
1323 "The optional arguments @var{start} and @var{end} allow\n"
1324 "a specified region of a vector (or linearized array) to be read,\n"
1325 "leaving the remainder of the vector unchanged.\n\n"
1326 "@code{uniform-array-read!} returns the number of objects read.\n"
1327 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1328 "returned by @code{(current-input-port)}.")
1329 #define FUNC_NAME s_scm_uniform_array_read_x
1331 if (SCM_UNBNDP (port_or_fd
))
1332 port_or_fd
= scm_cur_inp
;
1334 if (scm_is_uniform_vector (ura
))
1336 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1338 else if (SCM_I_ARRAYP (ura
))
1340 size_t base
, vlen
, cstart
, cend
;
1343 cra
= scm_ra2contig (ura
, 0);
1344 base
= SCM_I_ARRAY_BASE (cra
);
1345 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1346 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1350 if (!SCM_UNBNDP (start
))
1352 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1353 if (!SCM_UNBNDP (end
))
1354 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1357 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1358 scm_from_size_t (base
+ cstart
),
1359 scm_from_size_t (base
+ cend
));
1361 if (!scm_is_eq (cra
, ura
))
1362 scm_array_copy_x (cra
, ura
);
1365 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1366 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1368 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1372 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1373 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1374 "Writes all elements of @var{ura} as binary objects to\n"
1375 "@var{port-or-fdes}.\n\n"
1376 "The optional arguments @var{start}\n"
1377 "and @var{end} allow\n"
1378 "a specified region of a vector (or linearized array) to be written.\n\n"
1379 "The number of objects actually written is returned.\n"
1380 "@var{port-or-fdes} may be\n"
1381 "omitted, in which case it defaults to the value returned by\n"
1382 "@code{(current-output-port)}.")
1383 #define FUNC_NAME s_scm_uniform_array_write
1385 if (SCM_UNBNDP (port_or_fd
))
1386 port_or_fd
= scm_cur_outp
;
1388 if (scm_is_uniform_vector (ura
))
1390 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1392 else if (SCM_I_ARRAYP (ura
))
1394 size_t base
, vlen
, cstart
, cend
;
1397 cra
= scm_ra2contig (ura
, 1);
1398 base
= SCM_I_ARRAY_BASE (cra
);
1399 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1400 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1404 if (!SCM_UNBNDP (start
))
1406 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1407 if (!SCM_UNBNDP (end
))
1408 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1411 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1412 scm_from_size_t (base
+ cstart
),
1413 scm_from_size_t (base
+ cend
));
1417 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1418 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1420 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1427 static scm_t_bits scm_tc16_bitvector
;
1429 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1430 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1431 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1434 bitvector_free (SCM vec
)
1436 scm_gc_free (BITVECTOR_BITS (vec
),
1437 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1443 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1445 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1446 size_t word_len
= (bit_len
+31)/32;
1447 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1450 scm_puts ("#*", port
);
1451 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1453 scm_t_uint32 mask
= 1;
1454 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1455 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1462 bitvector_equalp (SCM vec1
, SCM vec2
)
1464 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1465 size_t word_len
= (bit_len
+ 31) / 32;
1466 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1467 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1468 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1470 /* compare lengths */
1471 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1473 /* avoid underflow in word_len-1 below. */
1476 /* compare full words */
1477 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1479 /* compare partial last words */
1480 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1486 scm_is_bitvector (SCM vec
)
1488 return IS_BITVECTOR (vec
);
1491 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1493 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1494 "return @code{#f}.")
1495 #define FUNC_NAME s_scm_bitvector_p
1497 return scm_from_bool (scm_is_bitvector (obj
));
1502 scm_c_make_bitvector (size_t len
, SCM fill
)
1504 size_t word_len
= (len
+ 31) / 32;
1508 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1510 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1512 if (!SCM_UNBNDP (fill
))
1513 scm_bitvector_fill_x (res
, fill
);
1518 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1519 (SCM len
, SCM fill
),
1520 "Create a new bitvector of length @var{len} and\n"
1521 "optionally initialize all elements to @var{fill}.")
1522 #define FUNC_NAME s_scm_make_bitvector
1524 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1528 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1530 "Create a new bitvector with the arguments as elements.")
1531 #define FUNC_NAME s_scm_bitvector
1533 return scm_list_to_bitvector (bits
);
1538 scm_c_bitvector_length (SCM vec
)
1540 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1541 return BITVECTOR_LENGTH (vec
);
1544 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1546 "Return the length of the bitvector @var{vec}.")
1547 #define FUNC_NAME s_scm_bitvector_length
1549 return scm_from_size_t (scm_c_bitvector_length (vec
));
1553 const scm_t_uint32
*
1554 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1556 return scm_array_handle_bit_writable_elements (h
);
1560 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1563 if (SCM_I_ARRAYP (vec
))
1564 vec
= SCM_I_ARRAY_V (vec
);
1565 if (IS_BITVECTOR (vec
))
1566 return BITVECTOR_BITS (vec
) + h
->base
/32;
1567 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1571 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1573 return h
->base
% 32;
1576 const scm_t_uint32
*
1577 scm_bitvector_elements (SCM vec
,
1578 scm_t_array_handle
*h
,
1583 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1588 scm_bitvector_writable_elements (SCM vec
,
1589 scm_t_array_handle
*h
,
1594 scm_generalized_vector_get_handle (vec
, h
);
1597 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1598 *offp
= scm_array_handle_bit_elements_offset (h
);
1599 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1602 return scm_array_handle_bit_writable_elements (h
);
1606 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1608 scm_t_array_handle handle
;
1609 const scm_t_uint32
*bits
;
1611 if (IS_BITVECTOR (vec
))
1613 if (idx
>= BITVECTOR_LENGTH (vec
))
1614 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1615 bits
= BITVECTOR_BITS(vec
);
1616 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1624 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1626 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1627 idx
= idx
*inc
+ off
;
1628 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1629 scm_array_handle_release (&handle
);
1634 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1636 "Return the element at index @var{idx} of the bitvector\n"
1638 #define FUNC_NAME s_scm_bitvector_ref
1640 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1645 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1647 scm_t_array_handle handle
;
1648 scm_t_uint32
*bits
, mask
;
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
);
1661 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1663 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1664 idx
= idx
*inc
+ off
;
1667 mask
= 1L << (idx
%32);
1668 if (scm_is_true (val
))
1669 bits
[idx
/32] |= mask
;
1671 bits
[idx
/32] &= ~mask
;
1673 if (!IS_BITVECTOR (vec
))
1674 scm_array_handle_release (&handle
);
1677 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1678 (SCM vec
, SCM idx
, SCM val
),
1679 "Set the element at index @var{idx} of the bitvector\n"
1680 "@var{vec} when @var{val} is true, else clear it.")
1681 #define FUNC_NAME s_scm_bitvector_set_x
1683 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1684 return SCM_UNSPECIFIED
;
1688 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1690 "Set all elements of the bitvector\n"
1691 "@var{vec} when @var{val} is true, else clear them.")
1692 #define FUNC_NAME s_scm_bitvector_fill_x
1694 scm_t_array_handle handle
;
1699 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1702 if (off
== 0 && inc
== 1 && len
> 0)
1706 size_t word_len
= (len
+ 31) / 32;
1707 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1709 if (scm_is_true (val
))
1711 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1712 bits
[word_len
-1] |= last_mask
;
1716 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1717 bits
[word_len
-1] &= ~last_mask
;
1723 for (i
= 0; i
< len
; i
++)
1724 scm_array_handle_set (&handle
, i
*inc
, val
);
1727 scm_array_handle_release (&handle
);
1729 return SCM_UNSPECIFIED
;
1733 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1735 "Return a new bitvector initialized with the elements\n"
1737 #define FUNC_NAME s_scm_list_to_bitvector
1739 size_t bit_len
= scm_to_size_t (scm_length (list
));
1740 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1741 size_t word_len
= (bit_len
+31)/32;
1742 scm_t_array_handle handle
;
1743 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1747 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1749 scm_t_uint32 mask
= 1;
1751 for (j
= 0; j
< 32 && j
< bit_len
;
1752 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1753 if (scm_is_true (SCM_CAR (list
)))
1757 scm_array_handle_release (&handle
);
1763 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1765 "Return a new list initialized with the elements\n"
1766 "of the bitvector @var{vec}.")
1767 #define FUNC_NAME s_scm_bitvector_to_list
1769 scm_t_array_handle handle
;
1775 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1778 if (off
== 0 && inc
== 1)
1782 size_t word_len
= (len
+ 31) / 32;
1785 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1787 scm_t_uint32 mask
= 1;
1788 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1789 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1795 for (i
= 0; i
< len
; i
++)
1796 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1799 scm_array_handle_release (&handle
);
1801 return scm_reverse_x (res
, SCM_EOL
);
1805 /* From mmix-arith.w by Knuth.
1807 Here's a fun way to count the number of bits in a tetrabyte.
1809 [This classical trick is called the ``Gillies--Miller method for
1810 sideways addition'' in {\sl The Preparation of Programs for an
1811 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1812 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1813 the tricks used here were suggested by Balbir Singh, Peter
1814 Rossmanith, and Stefan Schwoon.]
1818 count_ones (scm_t_uint32 x
)
1820 x
=x
-((x
>>1)&0x55555555);
1821 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1822 x
=(x
+(x
>>4))&0x0f0f0f0f;
1824 return (x
+(x
>>16)) & 0xff;
1827 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1828 (SCM b
, SCM bitvector
),
1829 "Return the number of occurrences of the boolean @var{b} in\n"
1831 #define FUNC_NAME s_scm_bit_count
1833 scm_t_array_handle handle
;
1837 int bit
= scm_to_bool (b
);
1840 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1843 if (off
== 0 && inc
== 1 && len
> 0)
1847 size_t word_len
= (len
+ 31) / 32;
1848 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1851 for (i
= 0; i
< word_len
-1; i
++)
1852 count
+= count_ones (bits
[i
]);
1853 count
+= count_ones (bits
[i
] & last_mask
);
1858 for (i
= 0; i
< len
; i
++)
1859 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1863 scm_array_handle_release (&handle
);
1865 return scm_from_size_t (bit
? count
: len
-count
);
1869 /* returns 32 for x == 0.
1872 find_first_one (scm_t_uint32 x
)
1875 /* do a binary search in x. */
1876 if ((x
& 0xFFFF) == 0)
1877 x
>>= 16, pos
+= 16;
1878 if ((x
& 0xFF) == 0)
1889 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1890 (SCM item
, SCM v
, SCM k
),
1891 "Return the index of the first occurrance of @var{item} in bit\n"
1892 "vector @var{v}, starting from @var{k}. If there is no\n"
1893 "@var{item} entry between @var{k} and the end of\n"
1894 "@var{bitvector}, then return @code{#f}. For example,\n"
1897 "(bit-position #t #*000101 0) @result{} 3\n"
1898 "(bit-position #f #*0001111 3) @result{} #f\n"
1900 #define FUNC_NAME s_scm_bit_position
1902 scm_t_array_handle handle
;
1903 size_t off
, len
, first_bit
;
1905 const scm_t_uint32
*bits
;
1906 int bit
= scm_to_bool (item
);
1907 SCM res
= SCM_BOOL_F
;
1909 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1910 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1912 if (off
== 0 && inc
== 1 && len
> 0)
1914 size_t i
, word_len
= (len
+ 31) / 32;
1915 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1916 size_t first_word
= first_bit
/ 32;
1917 scm_t_uint32 first_mask
=
1918 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1921 for (i
= first_word
; i
< word_len
; i
++)
1923 w
= (bit
? bits
[i
] : ~bits
[i
]);
1924 if (i
== first_word
)
1926 if (i
== word_len
-1)
1930 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1938 for (i
= first_bit
; i
< len
; i
++)
1940 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1941 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1943 res
= scm_from_size_t (i
);
1949 scm_array_handle_release (&handle
);
1955 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1956 (SCM v
, SCM kv
, SCM obj
),
1957 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1958 "selecting the entries to change. The return value is\n"
1961 "If @var{kv} is a bit vector, then those entries where it has\n"
1962 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1963 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1964 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1965 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1968 "(define bv #*01000010)\n"
1969 "(bit-set*! bv #*10010001 #t)\n"
1971 "@result{} #*11010011\n"
1974 "If @var{kv} is a u32vector, then its elements are\n"
1975 "indices into @var{v} which are set to @var{obj}.\n"
1978 "(define bv #*01000010)\n"
1979 "(bit-set*! bv #u32(5 2 7) #t)\n"
1981 "@result{} #*01100111\n"
1983 #define FUNC_NAME s_scm_bit_set_star_x
1985 scm_t_array_handle v_handle
;
1986 size_t v_off
, v_len
;
1988 scm_t_uint32
*v_bits
;
1991 /* Validate that OBJ is a boolean so this is done even if we don't
1994 bit
= scm_to_bool (obj
);
1996 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
1997 &v_off
, &v_len
, &v_inc
);
1999 if (scm_is_bitvector (kv
))
2001 scm_t_array_handle kv_handle
;
2002 size_t kv_off
, kv_len
;
2004 const scm_t_uint32
*kv_bits
;
2006 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2007 &kv_off
, &kv_len
, &kv_inc
);
2009 if (v_len
!= kv_len
)
2010 scm_misc_error (NULL
,
2011 "bit vectors must have equal length",
2014 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2016 size_t word_len
= (kv_len
+ 31) / 32;
2017 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2022 for (i
= 0; i
< word_len
-1; i
++)
2023 v_bits
[i
] &= ~kv_bits
[i
];
2024 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2028 for (i
= 0; i
< word_len
-1; i
++)
2029 v_bits
[i
] |= kv_bits
[i
];
2030 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2036 for (i
= 0; i
< kv_len
; i
++)
2037 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2038 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2041 scm_array_handle_release (&kv_handle
);
2044 else if (scm_is_true (scm_u32vector_p (kv
)))
2046 scm_t_array_handle kv_handle
;
2049 const scm_t_uint32
*kv_elts
;
2051 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2052 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2053 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2055 scm_array_handle_release (&kv_handle
);
2058 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2060 scm_array_handle_release (&v_handle
);
2062 return SCM_UNSPECIFIED
;
2067 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2068 (SCM v
, SCM kv
, SCM obj
),
2069 "Return a count of how many entries in bit vector @var{v} are\n"
2070 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2073 "If @var{kv} is a bit vector, then those entries where it has\n"
2074 "@code{#t} are the ones in @var{v} which are considered.\n"
2075 "@var{kv} and @var{v} must be the same length.\n"
2077 "If @var{kv} is a u32vector, then it contains\n"
2078 "the indexes in @var{v} to consider.\n"
2083 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2084 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2086 #define FUNC_NAME s_scm_bit_count_star
2088 scm_t_array_handle v_handle
;
2089 size_t v_off
, v_len
;
2091 const scm_t_uint32
*v_bits
;
2095 /* Validate that OBJ is a boolean so this is done even if we don't
2098 bit
= scm_to_bool (obj
);
2100 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2101 &v_off
, &v_len
, &v_inc
);
2103 if (scm_is_bitvector (kv
))
2105 scm_t_array_handle kv_handle
;
2106 size_t kv_off
, kv_len
;
2108 const scm_t_uint32
*kv_bits
;
2110 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2111 &kv_off
, &kv_len
, &kv_inc
);
2113 if (v_len
!= kv_len
)
2114 scm_misc_error (NULL
,
2115 "bit vectors must have equal length",
2118 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2120 size_t i
, word_len
= (kv_len
+ 31) / 32;
2121 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2122 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2124 for (i
= 0; i
< word_len
-1; i
++)
2125 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2126 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2131 for (i
= 0; i
< kv_len
; i
++)
2132 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2134 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2135 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2140 scm_array_handle_release (&kv_handle
);
2143 else if (scm_is_true (scm_u32vector_p (kv
)))
2145 scm_t_array_handle kv_handle
;
2148 const scm_t_uint32
*kv_elts
;
2150 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2151 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2153 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2154 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2158 scm_array_handle_release (&kv_handle
);
2161 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2163 scm_array_handle_release (&v_handle
);
2165 return scm_from_size_t (count
);
2169 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2171 "Modify the bit vector @var{v} by replacing each element with\n"
2173 #define FUNC_NAME s_scm_bit_invert_x
2175 scm_t_array_handle handle
;
2180 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2182 if (off
== 0 && inc
== 1 && len
> 0)
2184 size_t word_len
= (len
+ 31) / 32;
2185 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2188 for (i
= 0; i
< word_len
-1; i
++)
2190 bits
[i
] = bits
[i
] ^ last_mask
;
2195 for (i
= 0; i
< len
; i
++)
2196 scm_array_handle_set (&handle
, i
*inc
,
2197 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2200 scm_array_handle_release (&handle
);
2202 return SCM_UNSPECIFIED
;
2208 scm_istr2bve (SCM str
)
2210 scm_t_array_handle handle
;
2211 size_t len
= scm_i_string_length (str
);
2212 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2220 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2221 c_str
= scm_i_string_chars (str
);
2223 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2229 for (mask
= 1L; j
--; mask
<<= 1)
2244 scm_array_handle_release (&handle
);
2245 scm_remember_upto_here_1 (str
);
2252 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2257 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2259 if (k
== SCM_I_ARRAY_NDIM (ra
))
2260 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2262 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2263 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2265 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2269 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2276 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2278 "Return a list consisting of all the elements, in order, of\n"
2280 #define FUNC_NAME s_scm_array_to_list
2282 if (scm_is_generalized_vector (v
))
2283 return scm_generalized_vector_to_list (v
);
2284 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2285 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2287 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2292 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2294 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2295 (SCM type
, SCM shape
, SCM lst
),
2296 "Return an array of the type @var{type}\n"
2297 "with elements the same as those of @var{lst}.\n"
2299 "The argument @var{shape} determines the number of dimensions\n"
2300 "of the array and their shape. It is either an exact integer,\n"
2302 "number of dimensions directly, or a list whose length\n"
2303 "specifies the number of dimensions and each element specified\n"
2304 "the lower and optionally the upper bound of the corresponding\n"
2306 "When the element is list of two elements, these elements\n"
2307 "give the lower and upper bounds. When it is an exact\n"
2308 "integer, it gives only the lower bound.")
2309 #define FUNC_NAME s_scm_list_to_typed_array
2313 scm_t_array_handle handle
;
2316 if (scm_is_integer (shape
))
2318 size_t k
= scm_to_size_t (shape
);
2322 shape
= scm_cons (scm_length (row
), shape
);
2323 if (k
> 0 && !scm_is_null (row
))
2324 row
= scm_car (row
);
2329 SCM shape_spec
= shape
;
2333 SCM spec
= scm_car (shape_spec
);
2334 if (scm_is_pair (spec
))
2335 shape
= scm_cons (spec
, shape
);
2337 shape
= scm_cons (scm_list_2 (spec
,
2338 scm_sum (scm_sum (spec
,
2340 scm_from_int (-1))),
2342 shape_spec
= scm_cdr (shape_spec
);
2343 if (scm_is_pair (shape_spec
))
2345 if (!scm_is_null (row
))
2346 row
= scm_car (row
);
2353 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2354 scm_reverse_x (shape
, SCM_EOL
));
2356 scm_array_get_handle (ra
, &handle
);
2357 l2ra (lst
, &handle
, 0, 0);
2358 scm_array_handle_release (&handle
);
2364 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2365 (SCM ndim
, SCM lst
),
2366 "Return an array with elements the same as those of @var{lst}.")
2367 #define FUNC_NAME s_scm_list_to_array
2369 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2374 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2376 if (k
== scm_array_handle_rank (handle
))
2377 scm_array_handle_set (handle
, pos
, lst
);
2380 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2381 ssize_t inc
= dim
->inc
;
2382 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2383 char *errmsg
= NULL
;
2386 while (n
> 0 && scm_is_pair (lst
))
2388 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2390 lst
= SCM_CDR (lst
);
2394 errmsg
= "too few elements for array dimension ~a, need ~a";
2395 if (!scm_is_null (lst
))
2396 errmsg
= "too many elements for array dimension ~a, want ~a";
2398 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2399 scm_from_size_t (len
)));
2403 #if SCM_ENABLE_DEPRECATED
2405 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2406 (SCM ndim
, SCM prot
, SCM lst
),
2407 "Return a uniform array of the type indicated by prototype\n"
2408 "@var{prot} with elements the same as those of @var{lst}.\n"
2409 "Elements must be of the appropriate type, no coercions are\n"
2412 "The argument @var{ndim} determines the number of dimensions\n"
2413 "of the array. It is either an exact integer, giving the\n"
2414 "number directly, or a list of exact integers, whose length\n"
2415 "specifies the number of dimensions and each element is the\n"
2416 "lower index bound of its dimension.")
2417 #define FUNC_NAME s_scm_list_to_uniform_array
2419 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2425 /* Print dimension DIM of ARRAY.
2429 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2430 SCM port
, scm_print_state
*pstate
)
2432 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2435 scm_putc ('(', port
);
2437 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2439 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2440 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2443 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2445 if (idx
< dim_spec
->ubnd
)
2446 scm_putc (' ', port
);
2447 base
+= dim_spec
->inc
;
2450 scm_putc (')', port
);
2454 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2458 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2460 long ndim
= SCM_I_ARRAY_NDIM (array
);
2461 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2462 SCM v
= SCM_I_ARRAY_V (array
);
2463 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2465 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2467 scm_putc ('#', port
);
2468 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2469 scm_intprint (ndim
, 10, port
);
2470 if (scm_is_uniform_vector (v
))
2471 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2472 else if (scm_is_bitvector (v
))
2473 scm_puts ("b", port
);
2474 else if (scm_is_string (v
))
2475 scm_puts ("a", port
);
2476 else if (!scm_is_vector (v
))
2477 scm_puts ("?", port
);
2479 for (i
= 0; i
< ndim
; i
++)
2481 if (dim_specs
[i
].lbnd
!= 0)
2483 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2489 if (print_lbnds
|| print_lens
)
2490 for (i
= 0; i
< ndim
; i
++)
2494 scm_putc ('@', port
);
2495 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2499 scm_putc (':', port
);
2500 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2507 /* Rank zero arrays, which are really just scalars, are printed
2508 specially. The consequent way would be to print them as
2512 where OBJ is the printed representation of the scalar, but we
2513 print them instead as
2517 to make them look less strange.
2519 Just printing them as
2523 would be correct in a way as well, but zero rank arrays are
2524 not really the same as Scheme values since they are boxed and
2525 can be modified with array-set!, say.
2527 scm_putc ('(', port
);
2528 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2529 scm_putc (')', port
);
2533 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2537 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2541 scm_putc ('#', port
);
2542 base
= SCM_I_ARRAY_BASE (array
);
2543 scm_puts ("<enclosed-array ", port
);
2544 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2545 scm_putc ('>', port
);
2549 /* Read an array. This function can also read vectors and uniform
2550 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2553 C is the first character read after the '#'.
2557 tag_to_type (const char *tag
, SCM port
)
2559 #if SCM_ENABLE_DEPRECATED
2561 /* Recognize the old syntax.
2563 const char *instead
;
2595 if (instead
&& tag
[1] == '\0')
2597 scm_c_issue_deprecation_warning_fmt
2598 ("The tag '%c' is deprecated for uniform vectors. "
2599 "Use '%s' instead.", tag
[0], instead
);
2600 return scm_from_locale_symbol (instead
);
2608 return scm_from_locale_symbol (tag
);
2612 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2621 c
= scm_getc (port
);
2624 while ('0' <= c
&& c
<= '9')
2626 res
= 10*res
+ c
-'0';
2628 c
= scm_getc (port
);
2637 scm_i_read_array (SCM port
, int c
)
2644 SCM shape
= SCM_BOOL_F
, elements
;
2646 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2647 the array code can not deal with zero-length dimensions yet, and
2648 we want to allow zero-length vectors, of course.
2652 scm_ungetc (c
, port
);
2653 return scm_vector (scm_read (port
));
2656 /* Disambiguate between '#f' and uniform floating point vectors.
2660 c
= scm_getc (port
);
2661 if (c
!= '3' && c
!= '6')
2664 scm_ungetc (c
, port
);
2671 goto continue_reading_tag
;
2677 c
= read_decimal_integer (port
, c
, &rank
);
2679 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2685 continue_reading_tag
:
2686 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2689 c
= scm_getc (port
);
2691 tag
[tag_len
] = '\0';
2695 if (c
== '@' || c
== ':')
2701 ssize_t lbnd
= 0, len
= 0;
2706 c
= scm_getc (port
);
2707 c
= read_decimal_integer (port
, c
, &lbnd
);
2710 s
= scm_from_ssize_t (lbnd
);
2714 c
= scm_getc (port
);
2715 c
= read_decimal_integer (port
, c
, &len
);
2716 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2719 shape
= scm_cons (s
, shape
);
2720 } while (c
== '@' || c
== ':');
2722 shape
= scm_reverse_x (shape
, SCM_EOL
);
2725 /* Read nested lists of elements.
2728 scm_i_input_error (NULL
, port
,
2729 "missing '(' in vector or array literal",
2731 scm_ungetc (c
, port
);
2732 elements
= scm_read (port
);
2734 if (scm_is_false (shape
))
2735 shape
= scm_from_size_t (rank
);
2736 else if (scm_ilength (shape
) != rank
)
2739 "the number of shape specifications must match the array rank",
2742 /* Handle special print syntax of rank zero arrays; see
2743 scm_i_print_array for a rationale.
2747 if (!scm_is_pair (elements
))
2748 scm_i_input_error (NULL
, port
,
2749 "too few elements in array literal, need 1",
2751 if (!scm_is_null (SCM_CDR (elements
)))
2752 scm_i_input_error (NULL
, port
,
2753 "too many elements in array literal, want 1",
2755 elements
= SCM_CAR (elements
);
2760 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2763 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2766 #define FUNC_NAME s_scm_array_type
2768 if (SCM_I_ARRAYP (ra
))
2769 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2770 else if (scm_is_generalized_vector (ra
))
2771 return scm_i_generalized_vector_type (ra
);
2772 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2773 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2775 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2779 #if SCM_ENABLE_DEPRECATED
2781 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2783 "Return an object that would produce an array of the same type\n"
2784 "as @var{array}, if used as the @var{prototype} for\n"
2785 "@code{make-uniform-array}.")
2786 #define FUNC_NAME s_scm_array_prototype
2788 if (SCM_I_ARRAYP (ra
))
2789 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2790 else if (scm_is_generalized_vector (ra
))
2791 return scm_i_get_old_prototype (ra
);
2792 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2793 return SCM_UNSPECIFIED
;
2795 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2802 array_mark (SCM ptr
)
2804 return SCM_I_ARRAY_V (ptr
);
2808 array_free (SCM ptr
)
2810 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
2811 (sizeof (scm_i_t_array
)
2812 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2817 #if SCM_ENABLE_DEPRECATED
2820 scm_make_ra (int ndim
)
2822 scm_c_issue_deprecation_warning
2823 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2824 return scm_i_make_ra (ndim
, 0);
2828 scm_shap2ra (SCM args
, const char *what
)
2830 scm_c_issue_deprecation_warning
2831 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2832 return scm_i_shap2ra (args
);
2836 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2838 scm_c_issue_deprecation_warning
2839 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2840 return scm_c_generalized_vector_ref (v
, pos
);
2844 scm_ra_set_contp (SCM ra
)
2846 scm_c_issue_deprecation_warning
2847 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2848 scm_i_ra_set_contp (ra
);
2852 scm_aind (SCM ra
, SCM args
, const char *what
)
2854 scm_t_array_handle handle
;
2857 scm_c_issue_deprecation_warning
2858 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2860 if (scm_is_integer (args
))
2861 args
= scm_list_1 (args
);
2863 scm_array_get_handle (ra
, &handle
);
2864 pos
= scm_array_handle_pos (&handle
, args
);
2865 scm_array_handle_release (&handle
);
2870 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2872 scm_c_issue_deprecation_warning
2873 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2875 scm_iprin1 (exp
, port
, pstate
);
2884 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2885 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
2886 scm_set_smob_free (scm_i_tc16_array
, array_free
);
2887 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2888 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2890 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2891 scm_set_smob_mark (scm_i_tc16_enclosed_array
, array_mark
);
2892 scm_set_smob_free (scm_i_tc16_enclosed_array
, array_free
);
2893 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2894 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2896 scm_add_feature ("array");
2898 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2899 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2900 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2901 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2903 init_type_creator_table ();
2905 #include "libguile/unif.x"