1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_i_tc16_array
;
83 scm_t_bits scm_i_tc16_enclosed_array
;
85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
86 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
88 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
90 typedef SCM
creator_proc (SCM len
, SCM fill
);
95 creator_proc
*creator
;
96 } type_creator_table
[] = {
97 { "a", SCM_UNSPECIFIED
, scm_make_string
},
98 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
99 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
100 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
101 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
102 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
103 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
104 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
105 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
106 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
107 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
108 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
109 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
110 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
115 init_type_creator_table ()
118 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
120 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
121 type_creator_table
[i
].type
= scm_permanent_object (sym
);
125 static creator_proc
*
126 type_to_creator (SCM type
)
130 if (scm_is_eq (type
, SCM_BOOL_T
))
131 return scm_make_vector
;
132 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
133 if (scm_is_eq (type
, type_creator_table
[i
].type
))
134 return type_creator_table
[i
].creator
;
136 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
140 make_typed_vector (SCM type
, size_t len
)
142 creator_proc
*creator
= type_to_creator (type
);
143 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
146 #if SCM_ENABLE_DEPRECATED
148 SCM_SYMBOL (scm_sym_s
, "s");
149 SCM_SYMBOL (scm_sym_l
, "l");
154 if (!SCM_REALP (obj
))
158 double x
= SCM_REAL_VALUE (obj
);
160 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
164 SCM_API
int scm_i_inump (SCM obj
);
165 SCM_API scm_t_signed_bits
scm_i_inum (SCM obj
);
168 prototype_to_type (SCM proto
)
170 const char *type_name
;
172 if (scm_is_eq (proto
, SCM_BOOL_T
))
174 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
176 else if (SCM_CHARP (proto
))
178 else if (scm_i_inump (proto
))
180 if (scm_i_inum (proto
) > 0)
185 else if (scm_is_eq (proto
, scm_sym_s
))
187 else if (scm_is_eq (proto
, scm_sym_l
))
189 else if (SCM_REALP (proto
)
190 || scm_is_true (scm_eqv_p (proto
,
191 scm_divide (scm_from_int (1),
199 else if (SCM_COMPLEXP (proto
))
201 else if (scm_is_null (proto
))
207 return scm_from_locale_symbol (type_name
);
213 scm_i_get_old_prototype (SCM uvec
)
215 if (scm_is_bitvector (uvec
))
217 else if (scm_is_string (uvec
))
218 return SCM_MAKE_CHAR ('a');
219 else if (scm_is_true (scm_s8vector_p (uvec
)))
220 return SCM_MAKE_CHAR ('\0');
221 else if (scm_is_true (scm_s16vector_p (uvec
)))
223 else if (scm_is_true (scm_u32vector_p (uvec
)))
224 return scm_from_int (1);
225 else if (scm_is_true (scm_s32vector_p (uvec
)))
226 return scm_from_int (-1);
227 else if (scm_is_true (scm_s64vector_p (uvec
)))
229 else if (scm_is_true (scm_f32vector_p (uvec
)))
230 return scm_from_double (1.0);
231 else if (scm_is_true (scm_f64vector_p (uvec
)))
232 return scm_divide (scm_from_int (1), scm_from_int (3));
233 else if (scm_is_true (scm_c64vector_p (uvec
)))
234 return scm_c_make_rectangular (0, 1);
235 else if (scm_is_vector (uvec
))
238 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
242 scm_make_uve (long k
, SCM prot
)
243 #define FUNC_NAME "scm_make_uve"
245 scm_c_issue_deprecation_warning
246 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
248 return make_typed_vector (prototype_to_type (prot
), k
);
255 scm_is_array (SCM obj
)
257 return (SCM_I_ENCLOSED_ARRAYP (obj
)
258 || SCM_I_ARRAYP (obj
)
259 || scm_is_generalized_vector (obj
));
263 scm_is_typed_array (SCM obj
, SCM type
)
265 if (SCM_I_ENCLOSED_ARRAYP (obj
))
267 /* Enclosed arrays are arrays but are not of any type.
272 /* Get storage vector.
274 if (SCM_I_ARRAYP (obj
))
275 obj
= SCM_I_ARRAY_V (obj
);
277 /* It must be a generalized vector (which includes vectors, strings, etc).
279 if (!scm_is_generalized_vector (obj
))
282 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
286 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
288 return scm_i_cvref (SCM_I_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
292 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
294 return ((const SCM
*)h
->elements
)[pos
];
298 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
301 if (SCM_I_ARRAYP (h
->array
))
302 return scm_c_string_ref (SCM_I_ARRAY_V (h
->array
), pos
);
304 return scm_c_string_ref (h
->array
, pos
);
308 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
310 pos
+= scm_array_handle_bit_elements_offset (h
);
312 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
316 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
320 if (SCM_I_ENCLOSED_ARRAYP (v
))
322 h
->ref
= enclosed_ref
;
323 return enclosed_ref (h
, pos
);
326 if (SCM_I_ARRAYP (v
))
327 v
= SCM_I_ARRAY_V (v
);
329 if (scm_is_vector (v
))
331 h
->elements
= scm_array_handle_elements (h
);
334 else if (scm_is_uniform_vector (v
))
336 h
->elements
= scm_array_handle_uniform_elements (h
);
337 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
339 else if (scm_is_string (v
))
343 else if (scm_is_bitvector (v
))
345 h
->elements
= scm_array_handle_bit_elements (h
);
346 h
->ref
= bitvector_ref
;
349 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
351 return h
->ref (h
, pos
);
355 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
357 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
361 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
363 ((SCM
*)h
->writable_elements
)[pos
] = val
;
367 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
370 if (SCM_I_ARRAYP (h
->array
))
371 scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
373 scm_c_string_set_x (h
->array
, pos
, val
);
377 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
380 pos
+= scm_array_handle_bit_elements_offset (h
);
381 mask
= 1l << (pos
% 32);
382 if (scm_to_bool (val
))
383 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] |= mask
;
385 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] &= ~mask
;
389 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
393 if (SCM_I_ENCLOSED_ARRAYP (v
))
395 h
->set
= enclosed_set
;
396 enclosed_set (h
, pos
, val
);
400 if (SCM_I_ARRAYP (v
))
401 v
= SCM_I_ARRAY_V (v
);
403 if (scm_is_vector (v
))
405 h
->writable_elements
= scm_array_handle_writable_elements (h
);
408 else if (scm_is_uniform_vector (v
))
410 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
411 h
->set
= scm_i_uniform_vector_set_proc (v
);
413 else if (scm_is_string (v
))
417 else if (scm_is_bitvector (v
))
419 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
420 h
->set
= bitvector_set
;
423 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
425 h
->set (h
, pos
, val
);
429 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
432 h
->ref
= memoize_ref
;
433 h
->set
= memoize_set
;
435 if (SCM_I_ARRAYP (array
) || SCM_I_ENCLOSED_ARRAYP (array
))
437 h
->dims
= SCM_I_ARRAY_DIMS (array
);
438 h
->base
= SCM_I_ARRAY_BASE (array
);
440 else if (scm_is_generalized_vector (array
))
443 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
449 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
453 scm_array_handle_release (scm_t_array_handle
*h
)
455 /* Nothing to do here until arrays need to be reserved for real.
460 scm_array_handle_rank (scm_t_array_handle
*h
)
462 if (SCM_I_ARRAYP (h
->array
) || SCM_I_ENCLOSED_ARRAYP (h
->array
))
463 return SCM_I_ARRAY_NDIM (h
->array
);
469 scm_array_handle_dims (scm_t_array_handle
*h
)
475 scm_array_handle_elements (scm_t_array_handle
*h
)
478 if (SCM_I_ARRAYP (vec
))
479 vec
= SCM_I_ARRAY_V (vec
);
480 if (SCM_I_IS_VECTOR (vec
))
481 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
482 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
486 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
489 if (SCM_I_ARRAYP (vec
))
490 vec
= SCM_I_ARRAY_V (vec
);
491 if (SCM_I_IS_VECTOR (vec
))
492 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
493 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
496 #if SCM_ENABLE_DEPRECATED
498 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
500 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
502 #define FUNC_NAME s_scm_array_p
504 if (!SCM_UNBNDP (prot
))
506 scm_c_issue_deprecation_warning
507 ("Using prototypes with `array?' is deprecated."
508 " Use `typed-array?' instead.");
510 return scm_typed_array_p (obj
, prototype_to_type (prot
));
513 return scm_from_bool (scm_is_array (obj
));
517 #else /* !SCM_ENABLE_DEPRECATED */
519 /* We keep the old 2-argument C prototype for a while although the old
520 PROT argument is always ignored now. C code should probably use
521 scm_is_array or scm_is_typed_array anyway.
524 static SCM
scm_i_array_p (SCM obj
);
526 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
528 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
530 #define FUNC_NAME s_scm_i_array_p
532 return scm_from_bool (scm_is_array (obj
));
537 scm_array_p (SCM obj
, SCM prot
)
539 return scm_from_bool (scm_is_array (obj
));
542 #endif /* !SCM_ENABLE_DEPRECATED */
545 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
547 "Return @code{#t} if the @var{obj} is an array of type\n"
548 "@var{type}, and @code{#f} if not.")
549 #define FUNC_NAME s_scm_typed_array_p
551 return scm_from_bool (scm_is_typed_array (obj
, type
));
556 scm_c_array_rank (SCM array
)
558 scm_t_array_handle handle
;
561 scm_array_get_handle (array
, &handle
);
562 res
= scm_array_handle_rank (&handle
);
563 scm_array_handle_release (&handle
);
567 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
569 "Return the number of dimensions of the array @var{array.}\n")
570 #define FUNC_NAME s_scm_array_rank
572 return scm_from_size_t (scm_c_array_rank (array
));
577 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
579 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
580 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
582 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
584 #define FUNC_NAME s_scm_array_dimensions
586 scm_t_array_handle handle
;
591 scm_array_get_handle (ra
, &handle
);
592 s
= scm_array_handle_dims (&handle
);
593 k
= scm_array_handle_rank (&handle
);
596 res
= scm_cons (s
[k
].lbnd
597 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
598 scm_from_ssize_t (s
[k
].ubnd
),
600 : scm_from_ssize_t (1 + s
[k
].ubnd
),
603 scm_array_handle_release (&handle
);
609 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
611 "Return the root vector of a shared array.")
612 #define FUNC_NAME s_scm_shared_array_root
614 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
615 return SCM_I_ARRAY_V (ra
);
616 else if (scm_is_generalized_vector (ra
))
618 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
623 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
625 "Return the root vector index of the first element in the array.")
626 #define FUNC_NAME s_scm_shared_array_offset
628 scm_t_array_handle handle
;
631 scm_array_get_handle (ra
, &handle
);
632 res
= scm_from_size_t (handle
.base
);
633 scm_array_handle_release (&handle
);
639 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
641 "For each dimension, return the distance between elements in the root vector.")
642 #define FUNC_NAME s_scm_shared_array_increments
644 scm_t_array_handle handle
;
649 scm_array_get_handle (ra
, &handle
);
650 k
= scm_array_handle_rank (&handle
);
651 s
= scm_array_handle_dims (&handle
);
653 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
654 scm_array_handle_release (&handle
);
660 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
662 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
664 size_t k
= scm_array_handle_rank (h
);
666 while (k
> 0 && scm_is_pair (indices
))
668 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
669 pos
+= (i
- s
->lbnd
) * s
->inc
;
672 indices
= SCM_CDR (indices
);
674 if (k
> 0 || !scm_is_null (indices
))
675 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
676 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
681 scm_i_make_ra (int ndim
, int enclosed
)
683 scm_t_bits tag
= enclosed
? scm_i_tc16_enclosed_array
: scm_i_tc16_array
;
685 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
686 scm_gc_malloc ((sizeof (scm_i_t_array
) +
687 ndim
* sizeof (scm_t_array_dim
)),
689 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
693 static char s_bad_spec
[] = "Bad scm_array dimension";
696 /* Increments will still need to be set. */
699 scm_i_shap2ra (SCM args
)
703 int ndim
= scm_ilength (args
);
705 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
707 ra
= scm_i_make_ra (ndim
, 0);
708 SCM_I_ARRAY_BASE (ra
) = 0;
709 s
= SCM_I_ARRAY_DIMS (ra
);
710 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
712 spec
= SCM_CAR (args
);
713 if (scm_is_integer (spec
))
715 if (scm_to_long (spec
) < 0)
716 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
718 s
->ubnd
= scm_to_long (spec
) - 1;
723 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
724 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
725 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
727 if (!scm_is_pair (sp
)
728 || !scm_is_integer (SCM_CAR (sp
))
729 || !scm_is_null (SCM_CDR (sp
)))
730 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
731 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
738 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
739 (SCM type
, SCM fill
, SCM bounds
),
740 "Create and return an array of type @var{type}.")
741 #define FUNC_NAME s_scm_make_typed_array
745 creator_proc
*creator
;
748 creator
= type_to_creator (type
);
749 ra
= scm_i_shap2ra (bounds
);
750 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
751 s
= SCM_I_ARRAY_DIMS (ra
);
752 k
= SCM_I_ARRAY_NDIM (ra
);
757 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
758 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
761 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
762 fill
= SCM_UNDEFINED
;
764 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
766 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
767 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
768 return SCM_I_ARRAY_V (ra
);
773 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
774 (SCM fill
, SCM bounds
),
775 "Create and return an array.")
776 #define FUNC_NAME s_scm_make_array
778 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
782 #if SCM_ENABLE_DEPRECATED
784 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
785 (SCM dims
, SCM prot
, SCM fill
),
786 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
787 "Create and return a uniform array or vector of type\n"
788 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
789 "length @var{length}. If @var{fill} is supplied, it's used to\n"
790 "fill the array, otherwise @var{prototype} is used.")
791 #define FUNC_NAME s_scm_dimensions_to_uniform_array
793 scm_c_issue_deprecation_warning
794 ("`dimensions->uniform-array' is deprecated. "
795 "Use `make-typed-array' instead.");
797 if (scm_is_integer (dims
))
798 dims
= scm_list_1 (dims
);
800 if (SCM_UNBNDP (fill
))
802 /* Using #\nul as the prototype yields a s8 array, but numeric
803 arrays can't store characters, so we have to special case this.
805 if (scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
806 fill
= scm_from_int (0);
811 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
818 scm_i_ra_set_contp (SCM ra
)
820 size_t k
= SCM_I_ARRAY_NDIM (ra
);
823 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
826 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
828 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
831 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
832 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
835 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
839 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
840 (SCM oldra
, SCM mapfunc
, SCM dims
),
841 "@code{make-shared-array} can be used to create shared subarrays of other\n"
842 "arrays. The @var{mapper} is a function that translates coordinates in\n"
843 "the new array into coordinates in the old array. A @var{mapper} must be\n"
844 "linear, and its range must stay within the bounds of the old array, but\n"
845 "it can be otherwise arbitrary. A simple example:\n"
847 "(define fred (make-array #f 8 8))\n"
848 "(define freds-diagonal\n"
849 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
850 "(array-set! freds-diagonal 'foo 3)\n"
851 "(array-ref fred 3 3) @result{} foo\n"
852 "(define freds-center\n"
853 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
854 "(array-ref freds-center 0 0) @result{} foo\n"
856 #define FUNC_NAME s_scm_make_shared_array
858 scm_t_array_handle old_handle
;
864 long old_base
, old_min
, new_min
, old_max
, new_max
;
867 SCM_VALIDATE_REST_ARGUMENT (dims
);
868 SCM_VALIDATE_PROC (2, mapfunc
);
869 ra
= scm_i_shap2ra (dims
);
871 scm_array_get_handle (oldra
, &old_handle
);
873 if (SCM_I_ARRAYP (oldra
))
875 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
876 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
877 s
= scm_array_handle_dims (&old_handle
);
878 k
= scm_array_handle_rank (&old_handle
);
882 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
884 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
889 SCM_I_ARRAY_V (ra
) = oldra
;
890 old_base
= old_min
= 0;
891 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
895 s
= SCM_I_ARRAY_DIMS (ra
);
896 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
898 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
899 if (s
[k
].ubnd
< s
[k
].lbnd
)
901 if (1 == SCM_I_ARRAY_NDIM (ra
))
902 ra
= make_typed_vector (scm_array_type (ra
), 0);
904 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
905 scm_array_handle_release (&old_handle
);
910 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
911 i
= scm_array_handle_pos (&old_handle
, imap
);
912 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
914 k
= SCM_I_ARRAY_NDIM (ra
);
917 if (s
[k
].ubnd
> s
[k
].lbnd
)
919 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
920 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
921 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
924 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
926 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
929 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
930 indptr
= SCM_CDR (indptr
);
933 scm_array_handle_release (&old_handle
);
935 if (old_min
> new_min
|| old_max
< new_max
)
936 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
937 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
939 SCM v
= SCM_I_ARRAY_V (ra
);
940 size_t length
= scm_c_generalized_vector_length (v
);
941 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
943 if (s
->ubnd
< s
->lbnd
)
944 return make_typed_vector (scm_array_type (ra
), 0);
946 scm_i_ra_set_contp (ra
);
952 /* args are RA . DIMS */
953 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
955 "Return an array sharing contents with @var{array}, but with\n"
956 "dimensions arranged in a different order. There must be one\n"
957 "@var{dim} argument for each dimension of @var{array}.\n"
958 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
959 "and the rank of the array to be returned. Each integer in that\n"
960 "range must appear at least once in the argument list.\n"
962 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
963 "dimensions in the array to be returned, their positions in the\n"
964 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
965 "may have the same value, in which case the returned array will\n"
966 "have smaller rank than @var{array}.\n"
969 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
970 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
971 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
972 " #2((a 4) (b 5) (c 6))\n"
974 #define FUNC_NAME s_scm_transpose_array
977 scm_t_array_dim
*s
, *r
;
980 SCM_VALIDATE_REST_ARGUMENT (args
);
981 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
983 if (scm_is_generalized_vector (ra
))
985 /* Make sure that we are called with a single zero as
988 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
989 SCM_WRONG_NUM_ARGS ();
990 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
991 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
995 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
997 vargs
= scm_vector (args
);
998 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
999 SCM_WRONG_NUM_ARGS ();
1001 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
1003 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
1004 0, SCM_I_ARRAY_NDIM(ra
));
1009 res
= scm_i_make_ra (ndim
, 0);
1010 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
1011 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
1012 for (k
= ndim
; k
--;)
1014 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
1015 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
1017 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1019 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
1020 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
1021 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
1022 if (r
->ubnd
< r
->lbnd
)
1031 if (r
->ubnd
> s
->ubnd
)
1033 if (r
->lbnd
< s
->lbnd
)
1035 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1042 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1043 scm_i_ra_set_contp (res
);
1047 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1051 /* args are RA . AXES */
1052 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1054 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1055 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1056 "resembling an array of shared arrays. The dimensions of each shared\n"
1057 "array are the same as the @var{dim}th dimensions of the original array,\n"
1058 "the dimensions of the outer array are the same as those of the original\n"
1059 "array that did not match a @var{dim}.\n\n"
1060 "An enclosed array is not a general Scheme array. Its elements may not\n"
1061 "be set using @code{array-set!}. Two references to the same element of\n"
1062 "an enclosed array will be @code{equal?} but will not in general be\n"
1063 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1064 "enclosed array is unspecified.\n\n"
1067 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1068 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1069 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1070 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1072 #define FUNC_NAME s_scm_enclose_array
1074 SCM axv
, res
, ra_inr
;
1076 scm_t_array_dim vdim
, *s
= &vdim
;
1077 int ndim
, j
, k
, ninr
, noutr
;
1079 SCM_VALIDATE_REST_ARGUMENT (axes
);
1080 if (scm_is_null (axes
))
1081 axes
= scm_cons ((SCM_I_ARRAYP (ra
) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1082 ninr
= scm_ilength (axes
);
1084 SCM_WRONG_NUM_ARGS ();
1085 ra_inr
= scm_i_make_ra (ninr
, 0);
1087 if (scm_is_generalized_vector (ra
))
1090 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1092 SCM_I_ARRAY_V (ra_inr
) = ra
;
1093 SCM_I_ARRAY_BASE (ra_inr
) = 0;
1096 else if (SCM_I_ARRAYP (ra
))
1098 s
= SCM_I_ARRAY_DIMS (ra
);
1099 SCM_I_ARRAY_V (ra_inr
) = SCM_I_ARRAY_V (ra
);
1100 SCM_I_ARRAY_BASE (ra_inr
) = SCM_I_ARRAY_BASE (ra
);
1101 ndim
= SCM_I_ARRAY_NDIM (ra
);
1104 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1106 noutr
= ndim
- ninr
;
1108 SCM_WRONG_NUM_ARGS ();
1109 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1110 res
= scm_i_make_ra (noutr
, 1);
1111 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra_inr
);
1112 SCM_I_ARRAY_V (res
) = ra_inr
;
1113 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1115 if (!scm_is_integer (SCM_CAR (axes
)))
1116 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1117 j
= scm_to_int (SCM_CAR (axes
));
1118 SCM_I_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1119 SCM_I_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1120 SCM_I_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1121 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1123 c_axv
= scm_i_string_chars (axv
);
1124 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1128 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1129 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1130 SCM_I_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1132 scm_remember_upto_here_1 (axv
);
1133 scm_i_ra_set_contp (ra_inr
);
1134 scm_i_ra_set_contp (res
);
1141 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1143 "Return @code{#t} if its arguments would be acceptable to\n"
1144 "@code{array-ref}.")
1145 #define FUNC_NAME s_scm_array_in_bounds_p
1147 SCM res
= SCM_BOOL_T
;
1149 SCM_VALIDATE_REST_ARGUMENT (args
);
1151 if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
1153 size_t k
, ndim
= SCM_I_ARRAY_NDIM (v
);
1154 scm_t_array_dim
*s
= SCM_I_ARRAY_DIMS (v
);
1156 for (k
= 0; k
< ndim
; k
++)
1160 if (!scm_is_pair (args
))
1161 SCM_WRONG_NUM_ARGS ();
1162 ind
= scm_to_long (SCM_CAR (args
));
1163 args
= SCM_CDR (args
);
1165 if (ind
< s
[k
].lbnd
|| ind
> s
[k
].ubnd
)
1168 /* We do not stop the checking after finding a violation
1169 since we want to validate the type-correctness and
1170 number of arguments in any case.
1175 else if (scm_is_generalized_vector (v
))
1177 /* Since real arrays have been covered above, all generalized
1178 vectors are guaranteed to be zero-origin here.
1183 if (!scm_is_pair (args
))
1184 SCM_WRONG_NUM_ARGS ();
1185 ind
= scm_to_long (SCM_CAR (args
));
1186 args
= SCM_CDR (args
);
1187 res
= scm_from_bool (ind
>= 0
1188 && ind
< scm_c_generalized_vector_length (v
));
1191 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1193 if (!scm_is_null (args
))
1194 SCM_WRONG_NUM_ARGS ();
1201 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1205 int k
= SCM_I_ARRAY_NDIM (v
);
1206 SCM res
= scm_i_make_ra (k
, 0);
1207 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (v
);
1208 SCM_I_ARRAY_BASE (res
) = pos
;
1211 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= SCM_I_ARRAY_DIMS (v
)[k
].ubnd
;
1212 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= SCM_I_ARRAY_DIMS (v
)[k
].lbnd
;
1213 SCM_I_ARRAY_DIMS (res
)[k
].inc
= SCM_I_ARRAY_DIMS (v
)[k
].inc
;
1218 return scm_c_generalized_vector_ref (v
, pos
);
1221 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1223 "Return the element at the @code{(index1, index2)} element in\n"
1225 #define FUNC_NAME s_scm_array_ref
1227 scm_t_array_handle handle
;
1230 scm_array_get_handle (v
, &handle
);
1231 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
1232 scm_array_handle_release (&handle
);
1238 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1239 (SCM v
, SCM obj
, SCM args
),
1240 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1241 "@var{new-value}. The value returned by array-set! is unspecified.")
1242 #define FUNC_NAME s_scm_array_set_x
1244 scm_t_array_handle handle
;
1246 scm_array_get_handle (v
, &handle
);
1247 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
1248 scm_array_handle_release (&handle
);
1249 return SCM_UNSPECIFIED
;
1253 /* attempts to unroll an array into a one-dimensional array.
1254 returns the unrolled array or #f if it can't be done. */
1255 /* if strict is not SCM_UNDEFINED, return #f if returned array
1256 wouldn't have contiguous elements. */
1257 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1258 (SCM ra
, SCM strict
),
1259 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1260 "without changing their order (last subscript changing fastest), then\n"
1261 "@code{array-contents} returns that shared array, otherwise it returns\n"
1262 "@code{#f}. All arrays made by @var{make-array} and\n"
1263 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1264 "@var{make-shared-array} may not be.\n\n"
1265 "If the optional argument @var{strict} is provided, a shared array will\n"
1266 "be returned only if its elements are stored internally contiguous in\n"
1268 #define FUNC_NAME s_scm_array_contents
1272 if (scm_is_generalized_vector (ra
))
1275 if (SCM_I_ARRAYP (ra
))
1277 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
1278 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
1280 for (k
= 0; k
< ndim
; k
++)
1281 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1282 if (!SCM_UNBNDP (strict
))
1284 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1286 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1288 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
1289 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1296 SCM v
= SCM_I_ARRAY_V (ra
);
1297 size_t length
= scm_c_generalized_vector_length (v
);
1298 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
1302 sra
= scm_i_make_ra (1, 0);
1303 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
1304 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1305 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
1306 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
1307 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1310 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
1311 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1313 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1319 scm_ra2contig (SCM ra
, int copy
)
1324 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1325 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1326 k
= SCM_I_ARRAY_NDIM (ra
);
1327 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1329 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1331 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1332 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1333 0 == len
% SCM_LONG_BIT
))
1336 ret
= scm_i_make_ra (k
, 0);
1337 SCM_I_ARRAY_BASE (ret
) = 0;
1340 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1341 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1342 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1343 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1345 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1347 scm_array_copy_x (ra
, ret
);
1353 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1354 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1355 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1356 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1357 "binary objects from @var{port-or-fdes}.\n"
1358 "If an end of file is encountered,\n"
1359 "the objects up to that point are put into @var{ura}\n"
1360 "(starting at the beginning) and the remainder of the array is\n"
1362 "The optional arguments @var{start} and @var{end} allow\n"
1363 "a specified region of a vector (or linearized array) to be read,\n"
1364 "leaving the remainder of the vector unchanged.\n\n"
1365 "@code{uniform-array-read!} returns the number of objects read.\n"
1366 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1367 "returned by @code{(current-input-port)}.")
1368 #define FUNC_NAME s_scm_uniform_array_read_x
1370 if (SCM_UNBNDP (port_or_fd
))
1371 port_or_fd
= scm_current_input_port ();
1373 if (scm_is_uniform_vector (ura
))
1375 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1377 else if (SCM_I_ARRAYP (ura
))
1379 size_t base
, vlen
, cstart
, cend
;
1382 cra
= scm_ra2contig (ura
, 0);
1383 base
= SCM_I_ARRAY_BASE (cra
);
1384 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1385 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1389 if (!SCM_UNBNDP (start
))
1391 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1392 if (!SCM_UNBNDP (end
))
1393 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1396 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1397 scm_from_size_t (base
+ cstart
),
1398 scm_from_size_t (base
+ cend
));
1400 if (!scm_is_eq (cra
, ura
))
1401 scm_array_copy_x (cra
, ura
);
1404 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1405 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1407 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1411 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1412 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1413 "Writes all elements of @var{ura} as binary objects to\n"
1414 "@var{port-or-fdes}.\n\n"
1415 "The optional arguments @var{start}\n"
1416 "and @var{end} allow\n"
1417 "a specified region of a vector (or linearized array) to be written.\n\n"
1418 "The number of objects actually written is returned.\n"
1419 "@var{port-or-fdes} may be\n"
1420 "omitted, in which case it defaults to the value returned by\n"
1421 "@code{(current-output-port)}.")
1422 #define FUNC_NAME s_scm_uniform_array_write
1424 if (SCM_UNBNDP (port_or_fd
))
1425 port_or_fd
= scm_current_output_port ();
1427 if (scm_is_uniform_vector (ura
))
1429 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1431 else if (SCM_I_ARRAYP (ura
))
1433 size_t base
, vlen
, cstart
, cend
;
1436 cra
= scm_ra2contig (ura
, 1);
1437 base
= SCM_I_ARRAY_BASE (cra
);
1438 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1439 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1443 if (!SCM_UNBNDP (start
))
1445 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1446 if (!SCM_UNBNDP (end
))
1447 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1450 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1451 scm_from_size_t (base
+ cstart
),
1452 scm_from_size_t (base
+ cend
));
1456 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1457 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1459 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1466 static scm_t_bits scm_tc16_bitvector
;
1468 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1469 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1470 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1474 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1476 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1477 size_t word_len
= (bit_len
+31)/32;
1478 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1481 scm_puts ("#*", port
);
1482 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1484 scm_t_uint32 mask
= 1;
1485 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1486 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1493 bitvector_equalp (SCM vec1
, SCM vec2
)
1495 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1496 size_t word_len
= (bit_len
+ 31) / 32;
1497 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1498 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1499 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1501 /* compare lengths */
1502 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1504 /* avoid underflow in word_len-1 below. */
1507 /* compare full words */
1508 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1510 /* compare partial last words */
1511 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1517 scm_is_bitvector (SCM vec
)
1519 return IS_BITVECTOR (vec
);
1522 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1524 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1525 "return @code{#f}.")
1526 #define FUNC_NAME s_scm_bitvector_p
1528 return scm_from_bool (scm_is_bitvector (obj
));
1533 scm_c_make_bitvector (size_t len
, SCM fill
)
1535 size_t word_len
= (len
+ 31) / 32;
1539 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1541 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1543 if (!SCM_UNBNDP (fill
))
1544 scm_bitvector_fill_x (res
, fill
);
1549 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1550 (SCM len
, SCM fill
),
1551 "Create a new bitvector of length @var{len} and\n"
1552 "optionally initialize all elements to @var{fill}.")
1553 #define FUNC_NAME s_scm_make_bitvector
1555 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1559 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1561 "Create a new bitvector with the arguments as elements.")
1562 #define FUNC_NAME s_scm_bitvector
1564 return scm_list_to_bitvector (bits
);
1569 scm_c_bitvector_length (SCM vec
)
1571 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1572 return BITVECTOR_LENGTH (vec
);
1575 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1577 "Return the length of the bitvector @var{vec}.")
1578 #define FUNC_NAME s_scm_bitvector_length
1580 return scm_from_size_t (scm_c_bitvector_length (vec
));
1584 const scm_t_uint32
*
1585 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1587 return scm_array_handle_bit_writable_elements (h
);
1591 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1594 if (SCM_I_ARRAYP (vec
))
1595 vec
= SCM_I_ARRAY_V (vec
);
1596 if (IS_BITVECTOR (vec
))
1597 return BITVECTOR_BITS (vec
) + h
->base
/32;
1598 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1602 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1604 return h
->base
% 32;
1607 const scm_t_uint32
*
1608 scm_bitvector_elements (SCM vec
,
1609 scm_t_array_handle
*h
,
1614 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1619 scm_bitvector_writable_elements (SCM vec
,
1620 scm_t_array_handle
*h
,
1625 scm_generalized_vector_get_handle (vec
, h
);
1628 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1629 *offp
= scm_array_handle_bit_elements_offset (h
);
1630 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1633 return scm_array_handle_bit_writable_elements (h
);
1637 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1639 scm_t_array_handle handle
;
1640 const scm_t_uint32
*bits
;
1642 if (IS_BITVECTOR (vec
))
1644 if (idx
>= BITVECTOR_LENGTH (vec
))
1645 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1646 bits
= BITVECTOR_BITS(vec
);
1647 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1655 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1657 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1658 idx
= idx
*inc
+ off
;
1659 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1660 scm_array_handle_release (&handle
);
1665 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1667 "Return the element at index @var{idx} of the bitvector\n"
1669 #define FUNC_NAME s_scm_bitvector_ref
1671 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1676 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1678 scm_t_array_handle handle
;
1679 scm_t_uint32
*bits
, mask
;
1681 if (IS_BITVECTOR (vec
))
1683 if (idx
>= BITVECTOR_LENGTH (vec
))
1684 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1685 bits
= BITVECTOR_BITS(vec
);
1692 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1694 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1695 idx
= idx
*inc
+ off
;
1698 mask
= 1L << (idx
%32);
1699 if (scm_is_true (val
))
1700 bits
[idx
/32] |= mask
;
1702 bits
[idx
/32] &= ~mask
;
1704 if (!IS_BITVECTOR (vec
))
1705 scm_array_handle_release (&handle
);
1708 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1709 (SCM vec
, SCM idx
, SCM val
),
1710 "Set the element at index @var{idx} of the bitvector\n"
1711 "@var{vec} when @var{val} is true, else clear it.")
1712 #define FUNC_NAME s_scm_bitvector_set_x
1714 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1715 return SCM_UNSPECIFIED
;
1719 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1721 "Set all elements of the bitvector\n"
1722 "@var{vec} when @var{val} is true, else clear them.")
1723 #define FUNC_NAME s_scm_bitvector_fill_x
1725 scm_t_array_handle handle
;
1730 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1733 if (off
== 0 && inc
== 1 && len
> 0)
1737 size_t word_len
= (len
+ 31) / 32;
1738 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1740 if (scm_is_true (val
))
1742 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1743 bits
[word_len
-1] |= last_mask
;
1747 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1748 bits
[word_len
-1] &= ~last_mask
;
1754 for (i
= 0; i
< len
; i
++)
1755 scm_array_handle_set (&handle
, i
*inc
, val
);
1758 scm_array_handle_release (&handle
);
1760 return SCM_UNSPECIFIED
;
1764 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1766 "Return a new bitvector initialized with the elements\n"
1768 #define FUNC_NAME s_scm_list_to_bitvector
1770 size_t bit_len
= scm_to_size_t (scm_length (list
));
1771 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1772 size_t word_len
= (bit_len
+31)/32;
1773 scm_t_array_handle handle
;
1774 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1778 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1780 scm_t_uint32 mask
= 1;
1782 for (j
= 0; j
< 32 && j
< bit_len
;
1783 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1784 if (scm_is_true (SCM_CAR (list
)))
1788 scm_array_handle_release (&handle
);
1794 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1796 "Return a new list initialized with the elements\n"
1797 "of the bitvector @var{vec}.")
1798 #define FUNC_NAME s_scm_bitvector_to_list
1800 scm_t_array_handle handle
;
1806 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1809 if (off
== 0 && inc
== 1)
1813 size_t word_len
= (len
+ 31) / 32;
1816 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1818 scm_t_uint32 mask
= 1;
1819 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1820 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1826 for (i
= 0; i
< len
; i
++)
1827 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1830 scm_array_handle_release (&handle
);
1832 return scm_reverse_x (res
, SCM_EOL
);
1836 /* From mmix-arith.w by Knuth.
1838 Here's a fun way to count the number of bits in a tetrabyte.
1840 [This classical trick is called the ``Gillies--Miller method for
1841 sideways addition'' in {\sl The Preparation of Programs for an
1842 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1843 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1844 the tricks used here were suggested by Balbir Singh, Peter
1845 Rossmanith, and Stefan Schwoon.]
1849 count_ones (scm_t_uint32 x
)
1851 x
=x
-((x
>>1)&0x55555555);
1852 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1853 x
=(x
+(x
>>4))&0x0f0f0f0f;
1855 return (x
+(x
>>16)) & 0xff;
1858 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1859 (SCM b
, SCM bitvector
),
1860 "Return the number of occurrences of the boolean @var{b} in\n"
1862 #define FUNC_NAME s_scm_bit_count
1864 scm_t_array_handle handle
;
1868 int bit
= scm_to_bool (b
);
1871 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1874 if (off
== 0 && inc
== 1 && len
> 0)
1878 size_t word_len
= (len
+ 31) / 32;
1879 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1882 for (i
= 0; i
< word_len
-1; i
++)
1883 count
+= count_ones (bits
[i
]);
1884 count
+= count_ones (bits
[i
] & last_mask
);
1889 for (i
= 0; i
< len
; i
++)
1890 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1894 scm_array_handle_release (&handle
);
1896 return scm_from_size_t (bit
? count
: len
-count
);
1900 /* returns 32 for x == 0.
1903 find_first_one (scm_t_uint32 x
)
1906 /* do a binary search in x. */
1907 if ((x
& 0xFFFF) == 0)
1908 x
>>= 16, pos
+= 16;
1909 if ((x
& 0xFF) == 0)
1920 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1921 (SCM item
, SCM v
, SCM k
),
1922 "Return the index of the first occurrance of @var{item} in bit\n"
1923 "vector @var{v}, starting from @var{k}. If there is no\n"
1924 "@var{item} entry between @var{k} and the end of\n"
1925 "@var{bitvector}, then return @code{#f}. For example,\n"
1928 "(bit-position #t #*000101 0) @result{} 3\n"
1929 "(bit-position #f #*0001111 3) @result{} #f\n"
1931 #define FUNC_NAME s_scm_bit_position
1933 scm_t_array_handle handle
;
1934 size_t off
, len
, first_bit
;
1936 const scm_t_uint32
*bits
;
1937 int bit
= scm_to_bool (item
);
1938 SCM res
= SCM_BOOL_F
;
1940 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1941 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1943 if (off
== 0 && inc
== 1 && len
> 0)
1945 size_t i
, word_len
= (len
+ 31) / 32;
1946 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1947 size_t first_word
= first_bit
/ 32;
1948 scm_t_uint32 first_mask
=
1949 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1952 for (i
= first_word
; i
< word_len
; i
++)
1954 w
= (bit
? bits
[i
] : ~bits
[i
]);
1955 if (i
== first_word
)
1957 if (i
== word_len
-1)
1961 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1969 for (i
= first_bit
; i
< len
; i
++)
1971 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1972 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1974 res
= scm_from_size_t (i
);
1980 scm_array_handle_release (&handle
);
1986 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1987 (SCM v
, SCM kv
, SCM obj
),
1988 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1989 "selecting the entries to change. The return value is\n"
1992 "If @var{kv} is a bit vector, then those entries where it has\n"
1993 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1994 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1995 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1996 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1999 "(define bv #*01000010)\n"
2000 "(bit-set*! bv #*10010001 #t)\n"
2002 "@result{} #*11010011\n"
2005 "If @var{kv} is a u32vector, then its elements are\n"
2006 "indices into @var{v} which are set to @var{obj}.\n"
2009 "(define bv #*01000010)\n"
2010 "(bit-set*! bv #u32(5 2 7) #t)\n"
2012 "@result{} #*01100111\n"
2014 #define FUNC_NAME s_scm_bit_set_star_x
2016 scm_t_array_handle v_handle
;
2017 size_t v_off
, v_len
;
2019 scm_t_uint32
*v_bits
;
2022 /* Validate that OBJ is a boolean so this is done even if we don't
2025 bit
= scm_to_bool (obj
);
2027 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2028 &v_off
, &v_len
, &v_inc
);
2030 if (scm_is_bitvector (kv
))
2032 scm_t_array_handle kv_handle
;
2033 size_t kv_off
, kv_len
;
2035 const scm_t_uint32
*kv_bits
;
2037 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2038 &kv_off
, &kv_len
, &kv_inc
);
2040 if (v_len
!= kv_len
)
2041 scm_misc_error (NULL
,
2042 "bit vectors must have equal length",
2045 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2047 size_t word_len
= (kv_len
+ 31) / 32;
2048 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2053 for (i
= 0; i
< word_len
-1; i
++)
2054 v_bits
[i
] &= ~kv_bits
[i
];
2055 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2059 for (i
= 0; i
< word_len
-1; i
++)
2060 v_bits
[i
] |= kv_bits
[i
];
2061 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2067 for (i
= 0; i
< kv_len
; i
++)
2068 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2069 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2072 scm_array_handle_release (&kv_handle
);
2075 else if (scm_is_true (scm_u32vector_p (kv
)))
2077 scm_t_array_handle kv_handle
;
2080 const scm_t_uint32
*kv_elts
;
2082 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2083 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2084 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2086 scm_array_handle_release (&kv_handle
);
2089 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2091 scm_array_handle_release (&v_handle
);
2093 return SCM_UNSPECIFIED
;
2098 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2099 (SCM v
, SCM kv
, SCM obj
),
2100 "Return a count of how many entries in bit vector @var{v} are\n"
2101 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2104 "If @var{kv} is a bit vector, then those entries where it has\n"
2105 "@code{#t} are the ones in @var{v} which are considered.\n"
2106 "@var{kv} and @var{v} must be the same length.\n"
2108 "If @var{kv} is a u32vector, then it contains\n"
2109 "the indexes in @var{v} to consider.\n"
2114 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2115 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2117 #define FUNC_NAME s_scm_bit_count_star
2119 scm_t_array_handle v_handle
;
2120 size_t v_off
, v_len
;
2122 const scm_t_uint32
*v_bits
;
2126 /* Validate that OBJ is a boolean so this is done even if we don't
2129 bit
= scm_to_bool (obj
);
2131 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2132 &v_off
, &v_len
, &v_inc
);
2134 if (scm_is_bitvector (kv
))
2136 scm_t_array_handle kv_handle
;
2137 size_t kv_off
, kv_len
;
2139 const scm_t_uint32
*kv_bits
;
2141 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2142 &kv_off
, &kv_len
, &kv_inc
);
2144 if (v_len
!= kv_len
)
2145 scm_misc_error (NULL
,
2146 "bit vectors must have equal length",
2149 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2151 size_t i
, word_len
= (kv_len
+ 31) / 32;
2152 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2153 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2155 for (i
= 0; i
< word_len
-1; i
++)
2156 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2157 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2162 for (i
= 0; i
< kv_len
; i
++)
2163 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2165 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2166 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2171 scm_array_handle_release (&kv_handle
);
2174 else if (scm_is_true (scm_u32vector_p (kv
)))
2176 scm_t_array_handle kv_handle
;
2179 const scm_t_uint32
*kv_elts
;
2181 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2182 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2184 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2185 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2189 scm_array_handle_release (&kv_handle
);
2192 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2194 scm_array_handle_release (&v_handle
);
2196 return scm_from_size_t (count
);
2200 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2202 "Modify the bit vector @var{v} by replacing each element with\n"
2204 #define FUNC_NAME s_scm_bit_invert_x
2206 scm_t_array_handle handle
;
2211 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2213 if (off
== 0 && inc
== 1 && len
> 0)
2215 size_t word_len
= (len
+ 31) / 32;
2216 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2219 for (i
= 0; i
< word_len
-1; i
++)
2221 bits
[i
] = bits
[i
] ^ last_mask
;
2226 for (i
= 0; i
< len
; i
++)
2227 scm_array_handle_set (&handle
, i
*inc
,
2228 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2231 scm_array_handle_release (&handle
);
2233 return SCM_UNSPECIFIED
;
2239 scm_istr2bve (SCM str
)
2241 scm_t_array_handle handle
;
2242 size_t len
= scm_i_string_length (str
);
2243 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2251 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2252 c_str
= scm_i_string_chars (str
);
2254 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2260 for (mask
= 1L; j
--; mask
<<= 1)
2275 scm_array_handle_release (&handle
);
2276 scm_remember_upto_here_1 (str
);
2283 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2288 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2290 if (k
== SCM_I_ARRAY_NDIM (ra
))
2291 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2293 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2294 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2296 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2300 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2307 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2309 "Return a list consisting of all the elements, in order, of\n"
2311 #define FUNC_NAME s_scm_array_to_list
2313 if (scm_is_generalized_vector (v
))
2314 return scm_generalized_vector_to_list (v
);
2315 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2316 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2318 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2323 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2325 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2326 (SCM type
, SCM shape
, SCM lst
),
2327 "Return an array of the type @var{type}\n"
2328 "with elements the same as those of @var{lst}.\n"
2330 "The argument @var{shape} determines the number of dimensions\n"
2331 "of the array and their shape. It is either an exact integer,\n"
2333 "number of dimensions directly, or a list whose length\n"
2334 "specifies the number of dimensions and each element specified\n"
2335 "the lower and optionally the upper bound of the corresponding\n"
2337 "When the element is list of two elements, these elements\n"
2338 "give the lower and upper bounds. When it is an exact\n"
2339 "integer, it gives only the lower bound.")
2340 #define FUNC_NAME s_scm_list_to_typed_array
2344 scm_t_array_handle handle
;
2347 if (scm_is_integer (shape
))
2349 size_t k
= scm_to_size_t (shape
);
2353 shape
= scm_cons (scm_length (row
), shape
);
2354 if (k
> 0 && !scm_is_null (row
))
2355 row
= scm_car (row
);
2360 SCM shape_spec
= shape
;
2364 SCM spec
= scm_car (shape_spec
);
2365 if (scm_is_pair (spec
))
2366 shape
= scm_cons (spec
, shape
);
2368 shape
= scm_cons (scm_list_2 (spec
,
2369 scm_sum (scm_sum (spec
,
2371 scm_from_int (-1))),
2373 shape_spec
= scm_cdr (shape_spec
);
2374 if (scm_is_pair (shape_spec
))
2376 if (!scm_is_null (row
))
2377 row
= scm_car (row
);
2384 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2385 scm_reverse_x (shape
, SCM_EOL
));
2387 scm_array_get_handle (ra
, &handle
);
2388 l2ra (lst
, &handle
, 0, 0);
2389 scm_array_handle_release (&handle
);
2395 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2396 (SCM ndim
, SCM lst
),
2397 "Return an array with elements the same as those of @var{lst}.")
2398 #define FUNC_NAME s_scm_list_to_array
2400 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2405 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2407 if (k
== scm_array_handle_rank (handle
))
2408 scm_array_handle_set (handle
, pos
, lst
);
2411 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2412 ssize_t inc
= dim
->inc
;
2413 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2414 char *errmsg
= NULL
;
2417 while (n
> 0 && scm_is_pair (lst
))
2419 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2421 lst
= SCM_CDR (lst
);
2425 errmsg
= "too few elements for array dimension ~a, need ~a";
2426 if (!scm_is_null (lst
))
2427 errmsg
= "too many elements for array dimension ~a, want ~a";
2429 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2430 scm_from_size_t (len
)));
2434 #if SCM_ENABLE_DEPRECATED
2436 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2437 (SCM ndim
, SCM prot
, SCM lst
),
2438 "Return a uniform array of the type indicated by prototype\n"
2439 "@var{prot} with elements the same as those of @var{lst}.\n"
2440 "Elements must be of the appropriate type, no coercions are\n"
2443 "The argument @var{ndim} determines the number of dimensions\n"
2444 "of the array. It is either an exact integer, giving the\n"
2445 "number directly, or a list of exact integers, whose length\n"
2446 "specifies the number of dimensions and each element is the\n"
2447 "lower index bound of its dimension.")
2448 #define FUNC_NAME s_scm_list_to_uniform_array
2450 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2456 /* Print dimension DIM of ARRAY.
2460 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2461 SCM port
, scm_print_state
*pstate
)
2463 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2466 scm_putc ('(', port
);
2468 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2470 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2471 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2474 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2476 if (idx
< dim_spec
->ubnd
)
2477 scm_putc (' ', port
);
2478 base
+= dim_spec
->inc
;
2481 scm_putc (')', port
);
2485 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2489 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2491 long ndim
= SCM_I_ARRAY_NDIM (array
);
2492 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2493 SCM v
= SCM_I_ARRAY_V (array
);
2494 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2496 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2498 scm_putc ('#', port
);
2499 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2500 scm_intprint (ndim
, 10, port
);
2501 if (scm_is_uniform_vector (v
))
2502 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2503 else if (scm_is_bitvector (v
))
2504 scm_puts ("b", port
);
2505 else if (scm_is_string (v
))
2506 scm_puts ("a", port
);
2507 else if (!scm_is_vector (v
))
2508 scm_puts ("?", port
);
2510 for (i
= 0; i
< ndim
; i
++)
2512 if (dim_specs
[i
].lbnd
!= 0)
2514 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2520 if (print_lbnds
|| print_lens
)
2521 for (i
= 0; i
< ndim
; i
++)
2525 scm_putc ('@', port
);
2526 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2530 scm_putc (':', port
);
2531 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2538 /* Rank zero arrays, which are really just scalars, are printed
2539 specially. The consequent way would be to print them as
2543 where OBJ is the printed representation of the scalar, but we
2544 print them instead as
2548 to make them look less strange.
2550 Just printing them as
2554 would be correct in a way as well, but zero rank arrays are
2555 not really the same as Scheme values since they are boxed and
2556 can be modified with array-set!, say.
2558 scm_putc ('(', port
);
2559 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2560 scm_putc (')', port
);
2564 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2568 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2572 scm_putc ('#', port
);
2573 base
= SCM_I_ARRAY_BASE (array
);
2574 scm_puts ("<enclosed-array ", port
);
2575 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2576 scm_putc ('>', port
);
2580 /* Read an array. This function can also read vectors and uniform
2581 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2584 C is the first character read after the '#'.
2588 tag_to_type (const char *tag
, SCM port
)
2590 #if SCM_ENABLE_DEPRECATED
2592 /* Recognize the old syntax.
2594 const char *instead
;
2626 if (instead
&& tag
[1] == '\0')
2628 scm_c_issue_deprecation_warning_fmt
2629 ("The tag '%c' is deprecated for uniform vectors. "
2630 "Use '%s' instead.", tag
[0], instead
);
2631 return scm_from_locale_symbol (instead
);
2639 return scm_from_locale_symbol (tag
);
2643 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2652 c
= scm_getc (port
);
2655 while ('0' <= c
&& c
<= '9')
2657 res
= 10*res
+ c
-'0';
2659 c
= scm_getc (port
);
2668 scm_i_read_array (SCM port
, int c
)
2675 SCM shape
= SCM_BOOL_F
, elements
;
2677 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2678 the array code can not deal with zero-length dimensions yet, and
2679 we want to allow zero-length vectors, of course.
2683 scm_ungetc (c
, port
);
2684 return scm_vector (scm_read (port
));
2687 /* Disambiguate between '#f' and uniform floating point vectors.
2691 c
= scm_getc (port
);
2692 if (c
!= '3' && c
!= '6')
2695 scm_ungetc (c
, port
);
2702 goto continue_reading_tag
;
2708 c
= read_decimal_integer (port
, c
, &rank
);
2710 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2716 continue_reading_tag
:
2717 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2720 c
= scm_getc (port
);
2722 tag
[tag_len
] = '\0';
2726 if (c
== '@' || c
== ':')
2732 ssize_t lbnd
= 0, len
= 0;
2737 c
= scm_getc (port
);
2738 c
= read_decimal_integer (port
, c
, &lbnd
);
2741 s
= scm_from_ssize_t (lbnd
);
2745 c
= scm_getc (port
);
2746 c
= read_decimal_integer (port
, c
, &len
);
2748 scm_i_input_error (NULL
, port
,
2749 "array length must be non-negative",
2752 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2755 shape
= scm_cons (s
, shape
);
2756 } while (c
== '@' || c
== ':');
2758 shape
= scm_reverse_x (shape
, SCM_EOL
);
2761 /* Read nested lists of elements.
2764 scm_i_input_error (NULL
, port
,
2765 "missing '(' in vector or array literal",
2767 scm_ungetc (c
, port
);
2768 elements
= scm_read (port
);
2770 if (scm_is_false (shape
))
2771 shape
= scm_from_ssize_t (rank
);
2772 else if (scm_ilength (shape
) != rank
)
2775 "the number of shape specifications must match the array rank",
2778 /* Handle special print syntax of rank zero arrays; see
2779 scm_i_print_array for a rationale.
2783 if (!scm_is_pair (elements
))
2784 scm_i_input_error (NULL
, port
,
2785 "too few elements in array literal, need 1",
2787 if (!scm_is_null (SCM_CDR (elements
)))
2788 scm_i_input_error (NULL
, port
,
2789 "too many elements in array literal, want 1",
2791 elements
= SCM_CAR (elements
);
2796 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2799 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2802 #define FUNC_NAME s_scm_array_type
2804 if (SCM_I_ARRAYP (ra
))
2805 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2806 else if (scm_is_generalized_vector (ra
))
2807 return scm_i_generalized_vector_type (ra
);
2808 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2809 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2811 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2815 #if SCM_ENABLE_DEPRECATED
2817 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2819 "Return an object that would produce an array of the same type\n"
2820 "as @var{array}, if used as the @var{prototype} for\n"
2821 "@code{make-uniform-array}.")
2822 #define FUNC_NAME s_scm_array_prototype
2824 if (SCM_I_ARRAYP (ra
))
2825 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2826 else if (scm_is_generalized_vector (ra
))
2827 return scm_i_get_old_prototype (ra
);
2828 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2829 return SCM_UNSPECIFIED
;
2831 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2838 #if SCM_ENABLE_DEPRECATED
2841 scm_make_ra (int ndim
)
2843 scm_c_issue_deprecation_warning
2844 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2845 return scm_i_make_ra (ndim
, 0);
2849 scm_shap2ra (SCM args
, const char *what
)
2851 scm_c_issue_deprecation_warning
2852 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2853 return scm_i_shap2ra (args
);
2857 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2859 scm_c_issue_deprecation_warning
2860 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2861 return scm_c_generalized_vector_ref (v
, pos
);
2865 scm_ra_set_contp (SCM ra
)
2867 scm_c_issue_deprecation_warning
2868 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2869 scm_i_ra_set_contp (ra
);
2873 scm_aind (SCM ra
, SCM args
, const char *what
)
2875 scm_t_array_handle handle
;
2878 scm_c_issue_deprecation_warning
2879 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2881 if (scm_is_integer (args
))
2882 args
= scm_list_1 (args
);
2884 scm_array_get_handle (ra
, &handle
);
2885 pos
= scm_array_handle_pos (&handle
, args
) + SCM_I_ARRAY_BASE (ra
);
2886 scm_array_handle_release (&handle
);
2891 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2893 scm_c_issue_deprecation_warning
2894 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2896 scm_iprin1 (exp
, port
, pstate
);
2905 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2906 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2907 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2909 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2910 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2911 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2913 scm_add_feature ("array");
2915 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2916 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2917 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2919 init_type_creator_table ();
2921 #include "libguile/unif.x"