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_tc16_array
;
83 scm_t_bits scm_tc16_enclosed_array
;
85 typedef SCM
creator_proc (SCM len
, SCM fill
);
90 creator_proc
*creator
;
91 } type_creator_table
[] = {
92 { "a", SCM_UNSPECIFIED
, scm_make_string
},
93 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
94 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
95 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
96 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
97 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
98 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
99 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
100 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
101 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
102 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
103 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
104 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
105 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
110 init_type_creator_table ()
113 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
115 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
116 type_creator_table
[i
].type
= scm_permanent_object (sym
);
120 static creator_proc
*
121 type_to_creator (SCM type
)
125 if (scm_is_eq (type
, SCM_BOOL_T
))
126 return scm_make_vector
;
127 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
128 if (scm_is_eq (type
, type_creator_table
[i
].type
))
129 return type_creator_table
[i
].creator
;
131 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
135 make_typed_vector (SCM type
, size_t len
)
137 creator_proc
*creator
= type_to_creator (type
);
138 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
141 #if SCM_ENABLE_DEPRECATED
143 SCM_SYMBOL (scm_sym_s
, "s");
144 SCM_SYMBOL (scm_sym_l
, "l");
147 prototype_to_type (SCM proto
)
149 const char *type_name
;
151 if (scm_is_eq (proto
, SCM_BOOL_T
))
153 else if (scm_is_eq (proto
, SCM_MAKE_CHAR ('a')))
155 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
157 else if (scm_is_eq (proto
, scm_sym_s
))
159 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (1))))
161 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (-1))))
163 else if (scm_is_eq (proto
, scm_sym_l
))
165 else if (scm_is_true (scm_eqv_p (proto
, scm_from_double (1.0))))
167 else if (scm_is_true (scm_eqv_p (proto
, scm_divide (scm_from_int (1),
170 else if (scm_is_true (scm_eqv_p (proto
, scm_c_make_rectangular (0, 1))))
172 else if (scm_is_null (proto
))
178 return scm_from_locale_symbol (type_name
);
184 scm_i_get_old_prototype (SCM uvec
)
186 if (scm_is_bitvector (uvec
))
188 else if (scm_is_string (uvec
))
189 return SCM_MAKE_CHAR ('a');
190 else if (scm_is_true (scm_s8vector_p (uvec
)))
191 return SCM_MAKE_CHAR ('\0');
192 else if (scm_is_true (scm_s16vector_p (uvec
)))
194 else if (scm_is_true (scm_u32vector_p (uvec
)))
195 return scm_from_int (1);
196 else if (scm_is_true (scm_s32vector_p (uvec
)))
197 return scm_from_int (-1);
198 else if (scm_is_true (scm_s64vector_p (uvec
)))
200 else if (scm_is_true (scm_f32vector_p (uvec
)))
201 return scm_from_double (1.0);
202 else if (scm_is_true (scm_f64vector_p (uvec
)))
203 return scm_divide (scm_from_int (1), scm_from_int (3));
204 else if (scm_is_true (scm_c64vector_p (uvec
)))
205 return scm_c_make_rectangular (0, 1);
206 else if (scm_is_vector (uvec
))
209 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
213 scm_make_uve (long k
, SCM prot
)
214 #define FUNC_NAME "scm_make_uve"
216 scm_c_issue_deprecation_warning
217 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
219 return make_typed_vector (prototype_to_type (prot
), k
);
226 scm_is_array (SCM obj
)
228 return (SCM_ENCLOSED_ARRAYP (obj
)
230 || scm_is_generalized_vector (obj
));
234 scm_is_typed_array (SCM obj
, SCM type
)
236 if (SCM_ENCLOSED_ARRAYP (obj
))
238 /* Enclosed arrays are arrays but are not of any type.
243 /* Get storage vector.
245 if (SCM_ARRAYP (obj
))
246 obj
= SCM_ARRAY_V (obj
);
248 /* It must be a generalized vector (which includes vectors, strings, etc).
250 if (!scm_is_generalized_vector (obj
))
253 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
257 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
259 return scm_i_cvref (SCM_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
263 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
265 return ((const SCM
*)h
->elements
)[pos
];
269 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
272 if (SCM_ARRAYP (h
->array
))
273 return scm_c_string_ref (SCM_ARRAY_V (h
->array
), pos
);
275 return scm_c_string_ref (h
->array
, pos
);
279 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
281 pos
+= scm_array_handle_bit_elements_offset (h
);
283 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
287 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
291 if (SCM_ENCLOSED_ARRAYP (v
))
293 h
->ref
= enclosed_ref
;
294 return enclosed_ref (h
, pos
);
300 if (scm_is_vector (v
))
302 h
->elements
= scm_array_handle_elements (h
);
305 else if (scm_is_uniform_vector (v
))
307 h
->elements
= scm_array_handle_uniform_elements (h
);
308 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
310 else if (scm_is_string (v
))
314 else if (scm_is_bitvector (v
))
316 h
->elements
= scm_array_handle_bit_elements (h
);
317 h
->ref
= bitvector_ref
;
320 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
322 return h
->ref (h
, pos
);
326 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
328 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
332 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
334 ((SCM
*)h
->writable_elements
)[pos
] = val
;
338 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
341 if (SCM_ARRAYP (h
->array
))
342 return scm_c_string_set_x (SCM_ARRAY_V (h
->array
), pos
, val
);
344 return scm_c_string_set_x (h
->array
, pos
, val
);
348 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
351 pos
+= scm_array_handle_bit_elements_offset (h
);
352 mask
= 1l << (pos
% 32);
353 if (scm_to_bool (val
))
354 ((scm_t_uint32
*)h
->elements
)[pos
/32] |= mask
;
356 ((scm_t_uint32
*)h
->elements
)[pos
/32] &= ~mask
;
360 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
364 if (SCM_ENCLOSED_ARRAYP (v
))
366 h
->set
= enclosed_set
;
367 enclosed_set (h
, pos
, val
);
374 if (scm_is_vector (v
))
376 h
->writable_elements
= scm_array_handle_writable_elements (h
);
379 else if (scm_is_uniform_vector (v
))
381 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
382 h
->set
= scm_i_uniform_vector_set_proc (v
);
384 else if (scm_is_string (v
))
388 else if (scm_is_bitvector (v
))
390 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
391 h
->set
= bitvector_set
;
394 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
396 h
->set (h
, pos
, val
);
400 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
403 h
->ref
= memoize_ref
;
404 h
->set
= memoize_set
;
406 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
408 h
->dims
= SCM_ARRAY_DIMS (array
);
409 h
->base
= SCM_ARRAY_BASE (array
);
411 else if (scm_is_generalized_vector (array
))
414 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
420 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
424 scm_array_handle_release (scm_t_array_handle
*h
)
426 /* Nothing to do here until arrays need to be reserved for real.
431 scm_array_handle_rank (scm_t_array_handle
*h
)
433 if (SCM_ARRAYP (h
->array
) || SCM_ENCLOSED_ARRAYP (h
->array
))
434 return SCM_ARRAY_NDIM (h
->array
);
440 scm_array_handle_dims (scm_t_array_handle
*h
)
446 scm_array_handle_elements (scm_t_array_handle
*h
)
449 if (SCM_ARRAYP (vec
))
450 vec
= SCM_ARRAY_V (vec
);
451 if (SCM_I_IS_VECTOR (vec
))
452 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
453 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
457 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
460 if (SCM_ARRAYP (vec
))
461 vec
= SCM_ARRAY_V (vec
);
462 if (SCM_I_IS_VECTOR (vec
))
463 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
464 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
467 #if SCM_ENABLE_DEPRECATED
469 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
471 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
473 #define FUNC_NAME s_scm_array_p
475 if (!SCM_UNBNDP (prot
))
477 scm_c_issue_deprecation_warning
478 ("Using prototypes with `array?' is deprecated."
479 " Use `typed-array?' instead.");
481 return scm_typed_array_p (obj
, prototype_to_type (prot
));
484 return scm_from_bool (scm_is_array (obj
));
488 #else /* !SCM_ENABLE_DEPRECATED */
490 /* We keep the old 2-argument C prototype for a while although the old
491 PROT argument is always ignored now. C code should probably use
492 scm_is_array or scm_is_typed_array anyway.
495 static SCM
scm_i_array_p (SCM obj
);
497 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
499 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
501 #define FUNC_NAME s_scm_i_array_p
503 return scm_from_bool (scm_is_array (obj
));
508 scm_array_p (SCM obj
, SCM prot
)
510 return scm_from_bool (scm_is_array (obj
));
513 #endif /* !SCM_ENABLE_DEPRECATED */
516 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
518 "Return @code{#t} if the @var{obj} is an array of type\n"
519 "@var{type}, and @code{#f} if not.")
520 #define FUNC_NAME s_scm_typed_array_p
522 return scm_from_bool (scm_is_typed_array (obj
, type
));
527 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
529 "Return the number of dimensions of the array @var{array.}\n")
530 #define FUNC_NAME s_scm_array_rank
532 if (scm_is_generalized_vector (array
))
533 return scm_from_int (1);
535 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
536 return scm_from_size_t (SCM_ARRAY_NDIM (array
));
538 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
543 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
545 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
546 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
548 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
550 #define FUNC_NAME s_scm_array_dimensions
552 if (scm_is_generalized_vector (ra
))
553 return scm_list_1 (scm_generalized_vector_length (ra
));
555 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
561 k
= SCM_ARRAY_NDIM (ra
);
562 s
= SCM_ARRAY_DIMS (ra
);
564 res
= scm_cons (s
[k
].lbnd
565 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
566 scm_from_long (s
[k
].ubnd
),
568 : scm_from_long (1 + s
[k
].ubnd
),
573 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
578 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
580 "Return the root vector of a shared array.")
581 #define FUNC_NAME s_scm_shared_array_root
583 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
584 SCM_ARG1
, FUNC_NAME
);
585 return SCM_ARRAY_V (ra
);
590 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
592 "Return the root vector index of the first element in the array.")
593 #define FUNC_NAME s_scm_shared_array_offset
595 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
596 SCM_ARG1
, FUNC_NAME
);
597 return scm_from_int (SCM_ARRAY_BASE (ra
));
602 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
604 "For each dimension, return the distance between elements in the root vector.")
605 #define FUNC_NAME s_scm_shared_array_increments
611 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
612 SCM_ARG1
, FUNC_NAME
);
613 k
= SCM_ARRAY_NDIM (ra
);
614 s
= SCM_ARRAY_DIMS (ra
);
616 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
622 static char s_bad_ind
[] = "Bad scm_array index";
626 scm_aind (SCM ra
, SCM args
, const char *what
)
630 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
631 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
632 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
634 if (scm_is_integer (args
))
637 scm_error_num_args_subr (what
);
638 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
640 while (k
&& scm_is_pair (args
))
642 ind
= SCM_CAR (args
);
643 args
= SCM_CDR (args
);
644 if (!scm_is_integer (ind
))
645 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
646 j
= scm_to_long (ind
);
647 if (j
< s
->lbnd
|| j
> s
->ubnd
)
648 scm_out_of_range (what
, ind
);
649 pos
+= (j
- s
->lbnd
) * (s
->inc
);
653 if (k
!= 0 || !scm_is_null (args
))
654 scm_error_num_args_subr (what
);
661 scm_i_make_ra (int ndim
, scm_t_bits tag
)
664 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
665 scm_gc_malloc ((sizeof (scm_t_array
) +
666 ndim
* sizeof (scm_t_array_dim
)),
668 SCM_ARRAY_V (ra
) = SCM_BOOL_F
;
673 scm_make_ra (int ndim
)
675 return scm_i_make_ra (ndim
, scm_tc16_array
);
679 static char s_bad_spec
[] = "Bad scm_array dimension";
682 /* Increments will still need to be set. */
685 scm_shap2ra (SCM args
, const char *what
)
689 int ndim
= scm_ilength (args
);
691 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
693 ra
= scm_make_ra (ndim
);
694 SCM_ARRAY_BASE (ra
) = 0;
695 s
= SCM_ARRAY_DIMS (ra
);
696 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
698 spec
= SCM_CAR (args
);
699 if (scm_is_integer (spec
))
701 if (scm_to_long (spec
) < 0)
702 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
704 s
->ubnd
= scm_to_long (spec
) - 1;
709 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
710 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
711 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
713 if (!scm_is_pair (sp
)
714 || !scm_is_integer (SCM_CAR (sp
))
715 || !scm_is_null (SCM_CDR (sp
)))
716 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
717 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
724 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
725 (SCM type
, SCM fill
, SCM bounds
),
726 "Create and return an array of type @var{type}.")
727 #define FUNC_NAME s_scm_make_typed_array
731 creator_proc
*creator
;
734 creator
= type_to_creator (type
);
735 ra
= scm_shap2ra (bounds
, FUNC_NAME
);
736 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
737 s
= SCM_ARRAY_DIMS (ra
);
738 k
= SCM_ARRAY_NDIM (ra
);
743 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
);
744 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
747 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
748 fill
= SCM_UNDEFINED
;
750 SCM_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
752 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
753 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
754 return SCM_ARRAY_V (ra
);
759 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
760 (SCM fill
, SCM bounds
),
761 "Create and return an array.")
762 #define FUNC_NAME s_scm_make_array
764 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
768 #if SCM_ENABLE_DEPRECATED
770 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
771 (SCM dims
, SCM prot
, SCM fill
),
772 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
773 "Create and return a uniform array or vector of type\n"
774 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
775 "length @var{length}. If @var{fill} is supplied, it's used to\n"
776 "fill the array, otherwise @var{prototype} is used.")
777 #define FUNC_NAME s_scm_dimensions_to_uniform_array
779 scm_c_issue_deprecation_warning
780 ("`dimensions->uniform-array' is deprecated. "
781 "Use `make-typed-array' instead.");
783 if (scm_is_integer (dims
))
784 dims
= scm_list_1 (dims
);
785 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
792 scm_ra_set_contp (SCM ra
)
794 /* XXX - correct? one-dimensional arrays are always 'contiguous',
797 size_t k
= SCM_ARRAY_NDIM (ra
);
800 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
803 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
805 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
808 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
809 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
812 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
816 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
817 (SCM oldra
, SCM mapfunc
, SCM dims
),
818 "@code{make-shared-array} can be used to create shared subarrays of other\n"
819 "arrays. The @var{mapper} is a function that translates coordinates in\n"
820 "the new array into coordinates in the old array. A @var{mapper} must be\n"
821 "linear, and its range must stay within the bounds of the old array, but\n"
822 "it can be otherwise arbitrary. A simple example:\n"
824 "(define fred (make-array #f 8 8))\n"
825 "(define freds-diagonal\n"
826 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
827 "(array-set! freds-diagonal 'foo 3)\n"
828 "(array-ref fred 3 3) @result{} foo\n"
829 "(define freds-center\n"
830 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
831 "(array-ref freds-center 0 0) @result{} foo\n"
833 #define FUNC_NAME s_scm_make_shared_array
839 long old_min
, new_min
, old_max
, new_max
;
842 SCM_VALIDATE_REST_ARGUMENT (dims
);
843 SCM_VALIDATE_ARRAY (1, oldra
);
844 SCM_VALIDATE_PROC (2, mapfunc
);
845 ra
= scm_shap2ra (dims
, FUNC_NAME
);
846 if (SCM_ARRAYP (oldra
))
848 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
849 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
850 s
= SCM_ARRAY_DIMS (oldra
);
851 k
= SCM_ARRAY_NDIM (oldra
);
855 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
857 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
862 SCM_ARRAY_V (ra
) = oldra
;
864 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
867 s
= SCM_ARRAY_DIMS (ra
);
868 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
870 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
871 if (s
[k
].ubnd
< s
[k
].lbnd
)
873 if (1 == SCM_ARRAY_NDIM (ra
))
874 ra
= make_typed_vector (scm_array_type (ra
), 0);
876 SCM_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
880 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
881 if (SCM_ARRAYP (oldra
))
882 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
885 if (!scm_is_integer (imap
))
887 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
888 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
889 imap
= SCM_CAR (imap
);
891 i
= scm_to_size_t (imap
);
893 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
895 k
= SCM_ARRAY_NDIM (ra
);
898 if (s
[k
].ubnd
> s
[k
].lbnd
)
900 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
901 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
902 if (SCM_ARRAYP (oldra
))
904 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
907 if (!scm_is_integer (imap
))
909 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
910 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
911 imap
= SCM_CAR (imap
);
913 s
[k
].inc
= scm_to_long (imap
) - i
;
917 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
919 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
922 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
923 indptr
= SCM_CDR (indptr
);
925 if (old_min
> new_min
|| old_max
< new_max
)
926 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
927 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
929 SCM v
= SCM_ARRAY_V (ra
);
930 size_t length
= scm_c_generalized_vector_length (v
);
931 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
933 if (s
->ubnd
< s
->lbnd
)
934 return make_typed_vector (scm_array_type (ra
), 0);
936 scm_ra_set_contp (ra
);
942 /* args are RA . DIMS */
943 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
945 "Return an array sharing contents with @var{array}, but with\n"
946 "dimensions arranged in a different order. There must be one\n"
947 "@var{dim} argument for each dimension of @var{array}.\n"
948 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
949 "and the rank of the array to be returned. Each integer in that\n"
950 "range must appear at least once in the argument list.\n"
952 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
953 "dimensions in the array to be returned, their positions in the\n"
954 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
955 "may have the same value, in which case the returned array will\n"
956 "have smaller rank than @var{array}.\n"
959 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
960 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
961 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
962 " #2((a 4) (b 5) (c 6))\n"
964 #define FUNC_NAME s_scm_transpose_array
967 scm_t_array_dim
*s
, *r
;
970 SCM_VALIDATE_REST_ARGUMENT (args
);
971 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
973 if (scm_is_generalized_vector (ra
))
975 /* Make sure that we are called with a single zero as
978 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
979 SCM_WRONG_NUM_ARGS ();
980 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
981 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
985 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
987 vargs
= scm_vector (args
);
988 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
989 SCM_WRONG_NUM_ARGS ();
991 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
993 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
994 0, SCM_ARRAY_NDIM(ra
));
999 res
= scm_make_ra (ndim
);
1000 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
1001 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
1002 for (k
= ndim
; k
--;)
1004 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
1005 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
1007 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1009 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
1010 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
1011 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
1012 if (r
->ubnd
< r
->lbnd
)
1021 if (r
->ubnd
> s
->ubnd
)
1023 if (r
->lbnd
< s
->lbnd
)
1025 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1032 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1033 scm_ra_set_contp (res
);
1037 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1041 /* args are RA . AXES */
1042 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1044 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1045 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1046 "resembling an array of shared arrays. The dimensions of each shared\n"
1047 "array are the same as the @var{dim}th dimensions of the original array,\n"
1048 "the dimensions of the outer array are the same as those of the original\n"
1049 "array that did not match a @var{dim}.\n\n"
1050 "An enclosed array is not a general Scheme array. Its elements may not\n"
1051 "be set using @code{array-set!}. Two references to the same element of\n"
1052 "an enclosed array will be @code{equal?} but will not in general be\n"
1053 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1054 "enclosed array is unspecified.\n\n"
1057 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1058 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1059 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1060 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1062 #define FUNC_NAME s_scm_enclose_array
1064 SCM axv
, res
, ra_inr
;
1066 scm_t_array_dim vdim
, *s
= &vdim
;
1067 int ndim
, j
, k
, ninr
, noutr
;
1069 SCM_VALIDATE_REST_ARGUMENT (axes
);
1070 if (scm_is_null (axes
))
1071 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1072 ninr
= scm_ilength (axes
);
1074 SCM_WRONG_NUM_ARGS ();
1075 ra_inr
= scm_make_ra (ninr
);
1077 if (scm_is_generalized_vector (ra
))
1080 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1082 SCM_ARRAY_V (ra_inr
) = ra
;
1083 SCM_ARRAY_BASE (ra_inr
) = 0;
1086 else if (SCM_ARRAYP (ra
))
1088 s
= SCM_ARRAY_DIMS (ra
);
1089 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
1090 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
1091 ndim
= SCM_ARRAY_NDIM (ra
);
1094 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1096 noutr
= ndim
- ninr
;
1098 SCM_WRONG_NUM_ARGS ();
1099 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1100 res
= scm_i_make_ra (noutr
, scm_tc16_enclosed_array
);
1101 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
1102 SCM_ARRAY_V (res
) = ra_inr
;
1103 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1105 if (!scm_is_integer (SCM_CAR (axes
)))
1106 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1107 j
= scm_to_int (SCM_CAR (axes
));
1108 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1109 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1110 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1111 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1113 c_axv
= scm_i_string_chars (axv
);
1114 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1118 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1119 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1120 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1122 scm_remember_upto_here_1 (axv
);
1123 scm_ra_set_contp (ra_inr
);
1124 scm_ra_set_contp (res
);
1131 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1133 "Return @code{#t} if its arguments would be acceptable to\n"
1134 "@code{array-ref}.")
1135 #define FUNC_NAME s_scm_array_in_bounds_p
1137 SCM res
= SCM_BOOL_T
;
1139 SCM_VALIDATE_REST_ARGUMENT (args
);
1141 if (scm_is_generalized_vector (v
))
1145 if (!scm_is_pair (args
))
1146 SCM_WRONG_NUM_ARGS ();
1147 ind
= scm_to_long (SCM_CAR (args
));
1148 args
= SCM_CDR (args
);
1149 res
= scm_from_bool (ind
>= 0
1150 && ind
< scm_c_generalized_vector_length (v
));
1152 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1154 size_t k
= SCM_ARRAY_NDIM (v
);
1155 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (v
);
1161 if (!scm_is_pair (args
))
1162 SCM_WRONG_NUM_ARGS ();
1163 ind
= scm_to_long (SCM_CAR (args
));
1164 args
= SCM_CDR (args
);
1167 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1170 /* We do not stop the checking after finding a violation
1171 since we want to validate the type-correctness and
1172 number of arguments in any case.
1178 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1180 if (!scm_is_null (args
))
1181 SCM_WRONG_NUM_ARGS ();
1188 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1192 int k
= SCM_ARRAY_NDIM (v
);
1193 SCM res
= scm_make_ra (k
);
1194 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1195 SCM_ARRAY_BASE (res
) = pos
;
1198 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1199 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1200 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1205 return scm_c_generalized_vector_ref (v
, pos
);
1209 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1211 return scm_i_cvref (v
, pos
, 0);
1214 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1216 "Return the element at the @code{(index1, index2)} element in\n"
1218 #define FUNC_NAME s_scm_array_ref
1223 if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1225 enclosed
= SCM_ENCLOSED_ARRAYP (v
);
1226 pos
= scm_aind (v
, args
, FUNC_NAME
);
1227 v
= SCM_ARRAY_V (v
);
1232 if (SCM_NIMP (args
))
1234 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
1235 pos
= scm_to_long (SCM_CAR (args
));
1236 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1239 pos
= scm_to_long (args
);
1240 length
= scm_c_generalized_vector_length (v
);
1241 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1244 return scm_i_cvref (v
, pos
, enclosed
);
1247 scm_wrong_num_args (NULL
);
1249 scm_out_of_range (NULL
, scm_from_long (pos
));
1254 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1255 (SCM v
, SCM obj
, SCM args
),
1256 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1257 "@var{new-value}. The value returned by array-set! is unspecified.")
1258 #define FUNC_NAME s_scm_array_set_x
1264 pos
= scm_aind (v
, args
, FUNC_NAME
);
1265 v
= SCM_ARRAY_V (v
);
1267 else if (SCM_ENCLOSED_ARRAYP (v
))
1268 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-enclosed array");
1269 else if (scm_is_generalized_vector (v
))
1272 if (scm_is_pair (args
))
1274 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1275 pos
= scm_to_long (SCM_CAR (args
));
1278 pos
= scm_to_long (args
);
1279 length
= scm_c_generalized_vector_length (v
);
1280 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1283 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1285 scm_c_generalized_vector_set_x (v
, pos
, obj
);
1286 return SCM_UNSPECIFIED
;
1289 scm_out_of_range (NULL
, scm_from_long (pos
));
1291 scm_wrong_num_args (NULL
);
1295 /* attempts to unroll an array into a one-dimensional array.
1296 returns the unrolled array or #f if it can't be done. */
1297 /* if strict is not SCM_UNDEFINED, return #f if returned array
1298 wouldn't have contiguous elements. */
1299 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1300 (SCM ra
, SCM strict
),
1301 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1302 "without changing their order (last subscript changing fastest), then\n"
1303 "@code{array-contents} returns that shared array, otherwise it returns\n"
1304 "@code{#f}. All arrays made by @var{make-array} and\n"
1305 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1306 "@var{make-shared-array} may not be.\n\n"
1307 "If the optional argument @var{strict} is provided, a shared array will\n"
1308 "be returned only if its elements are stored internally contiguous in\n"
1310 #define FUNC_NAME s_scm_array_contents
1314 if (scm_is_generalized_vector (ra
))
1317 if (SCM_ARRAYP (ra
))
1319 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1320 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1322 for (k
= 0; k
< ndim
; k
++)
1323 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1324 if (!SCM_UNBNDP (strict
))
1326 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1328 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1330 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1331 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1338 SCM v
= SCM_ARRAY_V (ra
);
1339 size_t length
= scm_c_generalized_vector_length (v
);
1340 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1344 sra
= scm_make_ra (1);
1345 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1346 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1347 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1348 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1349 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1352 else if (SCM_ENCLOSED_ARRAYP (ra
))
1353 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1355 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1361 scm_ra2contig (SCM ra
, int copy
)
1366 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1367 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1368 k
= SCM_ARRAY_NDIM (ra
);
1369 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1371 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1373 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1374 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1375 0 == len
% SCM_LONG_BIT
))
1378 ret
= scm_make_ra (k
);
1379 SCM_ARRAY_BASE (ret
) = 0;
1382 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1383 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1384 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1385 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1387 SCM_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1389 scm_array_copy_x (ra
, ret
);
1395 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1396 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1397 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1398 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1399 "binary objects from @var{port-or-fdes}.\n"
1400 "If an end of file is encountered,\n"
1401 "the objects up to that point are put into @var{ura}\n"
1402 "(starting at the beginning) and the remainder of the array is\n"
1404 "The optional arguments @var{start} and @var{end} allow\n"
1405 "a specified region of a vector (or linearized array) to be read,\n"
1406 "leaving the remainder of the vector unchanged.\n\n"
1407 "@code{uniform-array-read!} returns the number of objects read.\n"
1408 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1409 "returned by @code{(current-input-port)}.")
1410 #define FUNC_NAME s_scm_uniform_array_read_x
1412 if (SCM_UNBNDP (port_or_fd
))
1413 port_or_fd
= scm_cur_inp
;
1415 if (scm_is_uniform_vector (ura
))
1417 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1419 else if (SCM_ARRAYP (ura
))
1421 size_t base
, vlen
, cstart
, cend
;
1424 cra
= scm_ra2contig (ura
, 0);
1425 base
= SCM_ARRAY_BASE (cra
);
1426 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1427 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1431 if (!SCM_UNBNDP (start
))
1433 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1434 if (!SCM_UNBNDP (end
))
1435 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1438 ans
= scm_uniform_vector_read_x (SCM_ARRAY_V (cra
), port_or_fd
,
1439 scm_from_size_t (base
+ cstart
),
1440 scm_from_size_t (base
+ cend
));
1442 if (!scm_is_eq (cra
, ura
))
1443 scm_array_copy_x (cra
, ura
);
1446 else if (SCM_ENCLOSED_ARRAYP (ura
))
1447 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1449 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1453 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1454 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1455 "Writes all elements of @var{ura} as binary objects to\n"
1456 "@var{port-or-fdes}.\n\n"
1457 "The optional arguments @var{start}\n"
1458 "and @var{end} allow\n"
1459 "a specified region of a vector (or linearized array) to be written.\n\n"
1460 "The number of objects actually written is returned.\n"
1461 "@var{port-or-fdes} may be\n"
1462 "omitted, in which case it defaults to the value returned by\n"
1463 "@code{(current-output-port)}.")
1464 #define FUNC_NAME s_scm_uniform_array_write
1466 if (SCM_UNBNDP (port_or_fd
))
1467 port_or_fd
= scm_cur_outp
;
1469 if (scm_is_uniform_vector (ura
))
1471 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1473 else if (SCM_ARRAYP (ura
))
1475 size_t base
, vlen
, cstart
, cend
;
1478 cra
= scm_ra2contig (ura
, 1);
1479 base
= SCM_ARRAY_BASE (cra
);
1480 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1481 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1485 if (!SCM_UNBNDP (start
))
1487 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1488 if (!SCM_UNBNDP (end
))
1489 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1492 ans
= scm_uniform_vector_write (SCM_ARRAY_V (cra
), port_or_fd
,
1493 scm_from_size_t (base
+ cstart
),
1494 scm_from_size_t (base
+ cend
));
1498 else if (SCM_ENCLOSED_ARRAYP (ura
))
1499 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1501 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1508 static scm_t_bits scm_tc16_bitvector
;
1510 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1511 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1512 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1515 bitvector_free (SCM vec
)
1517 scm_gc_free (BITVECTOR_BITS (vec
),
1518 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1524 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1526 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1527 size_t word_len
= (bit_len
+31)/32;
1528 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1531 scm_puts ("#*", port
);
1532 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1534 scm_t_uint32 mask
= 1;
1535 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1536 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1543 bitvector_equalp (SCM vec1
, SCM vec2
)
1545 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1546 size_t word_len
= (bit_len
+ 31) / 32;
1547 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1548 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1549 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1551 /* compare lengths */
1552 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1554 /* avoid underflow in word_len-1 below. */
1557 /* compare full words */
1558 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1560 /* compare partial last words */
1561 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1567 scm_is_bitvector (SCM vec
)
1569 return IS_BITVECTOR (vec
);
1572 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1574 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1575 "return @code{#f}.")
1576 #define FUNC_NAME s_scm_bitvector_p
1578 return scm_from_bool (scm_is_bitvector (obj
));
1583 scm_c_make_bitvector (size_t len
, SCM fill
)
1585 size_t word_len
= (len
+ 31) / 32;
1589 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1591 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1593 if (!SCM_UNBNDP (fill
))
1594 scm_bitvector_fill_x (res
, fill
);
1599 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1600 (SCM len
, SCM fill
),
1601 "Create a new bitvector of length @var{len} and\n"
1602 "optionally initialize all elements to @var{fill}.")
1603 #define FUNC_NAME s_scm_make_bitvector
1605 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1609 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1611 "Create a new bitvector with the arguments as elements.")
1612 #define FUNC_NAME s_scm_bitvector
1614 return scm_list_to_bitvector (bits
);
1619 scm_c_bitvector_length (SCM vec
)
1621 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1622 return BITVECTOR_LENGTH (vec
);
1625 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1627 "Return the length of the bitvector @var{vec}.")
1628 #define FUNC_NAME s_scm_bitvector_length
1630 return scm_from_size_t (scm_c_bitvector_length (vec
));
1634 const scm_t_uint32
*
1635 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1637 return scm_array_handle_bit_writable_elements (h
);
1641 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1644 if (SCM_ARRAYP (vec
))
1645 vec
= SCM_ARRAY_V (vec
);
1646 if (IS_BITVECTOR (vec
))
1647 return BITVECTOR_BITS (vec
) + h
->base
/32;
1648 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1652 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1654 return h
->base
% 32;
1657 const scm_t_uint32
*
1658 scm_bitvector_elements (SCM vec
,
1659 scm_t_array_handle
*h
,
1664 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1669 scm_bitvector_writable_elements (SCM vec
,
1670 scm_t_array_handle
*h
,
1675 scm_generalized_vector_get_handle (vec
, h
);
1678 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1679 *offp
= scm_array_handle_bit_elements_offset (h
);
1680 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1683 return scm_array_handle_bit_writable_elements (h
);
1687 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1689 scm_t_array_handle handle
;
1690 const scm_t_uint32
*bits
;
1692 if (IS_BITVECTOR (vec
))
1694 if (idx
>= BITVECTOR_LENGTH (vec
))
1695 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1696 bits
= BITVECTOR_BITS(vec
);
1697 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1705 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1707 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1708 idx
= idx
*inc
+ off
;
1709 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1710 scm_array_handle_release (&handle
);
1715 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1717 "Return the element at index @var{idx} of the bitvector\n"
1719 #define FUNC_NAME s_scm_bitvector_ref
1721 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1726 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1728 scm_t_array_handle handle
;
1729 scm_t_uint32
*bits
, mask
;
1731 if (IS_BITVECTOR (vec
))
1733 if (idx
>= BITVECTOR_LENGTH (vec
))
1734 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1735 bits
= BITVECTOR_BITS(vec
);
1742 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1744 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1745 idx
= idx
*inc
+ off
;
1748 mask
= 1L << (idx
%32);
1749 if (scm_is_true (val
))
1750 bits
[idx
/32] |= mask
;
1752 bits
[idx
/32] &= ~mask
;
1754 if (!IS_BITVECTOR (vec
))
1755 scm_array_handle_release (&handle
);
1758 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1759 (SCM vec
, SCM idx
, SCM val
),
1760 "Set the element at index @var{idx} of the bitvector\n"
1761 "@var{vec} when @var{val} is true, else clear it.")
1762 #define FUNC_NAME s_scm_bitvector_set_x
1764 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1765 return SCM_UNSPECIFIED
;
1769 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1771 "Set all elements of the bitvector\n"
1772 "@var{vec} when @var{val} is true, else clear them.")
1773 #define FUNC_NAME s_scm_bitvector_fill_x
1775 scm_t_array_handle handle
;
1780 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1783 if (off
== 0 && inc
== 1 && len
> 0)
1787 size_t word_len
= (len
+ 31) / 32;
1788 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1790 if (scm_is_true (val
))
1792 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1793 bits
[word_len
-1] |= last_mask
;
1797 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1798 bits
[word_len
-1] &= ~last_mask
;
1804 for (i
= 0; i
< len
; i
++)
1805 scm_array_handle_set (&handle
, i
*inc
, val
);
1808 scm_array_handle_release (&handle
);
1810 return SCM_UNSPECIFIED
;
1814 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1816 "Return a new bitvector initialized with the elements\n"
1818 #define FUNC_NAME s_scm_list_to_bitvector
1820 size_t bit_len
= scm_to_size_t (scm_length (list
));
1821 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1822 size_t word_len
= (bit_len
+31)/32;
1823 scm_t_array_handle handle
;
1824 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1828 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1830 scm_t_uint32 mask
= 1;
1832 for (j
= 0; j
< 32 && j
< bit_len
;
1833 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1834 if (scm_is_true (SCM_CAR (list
)))
1838 scm_array_handle_release (&handle
);
1844 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1846 "Return a new list initialized with the elements\n"
1847 "of the bitvector @var{vec}.")
1848 #define FUNC_NAME s_scm_bitvector_to_list
1850 scm_t_array_handle handle
;
1856 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1859 if (off
== 0 && inc
== 1)
1863 size_t word_len
= (len
+ 31) / 32;
1866 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1868 scm_t_uint32 mask
= 1;
1869 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1870 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1876 for (i
= 0; i
< len
; i
++)
1877 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1880 scm_array_handle_release (&handle
);
1882 return scm_reverse_x (res
, SCM_EOL
);
1886 /* From mmix-arith.w by Knuth.
1888 Here's a fun way to count the number of bits in a tetrabyte.
1890 [This classical trick is called the ``Gillies--Miller method for
1891 sideways addition'' in {\sl The Preparation of Programs for an
1892 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1893 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1894 the tricks used here were suggested by Balbir Singh, Peter
1895 Rossmanith, and Stefan Schwoon.]
1899 count_ones (scm_t_uint32 x
)
1901 x
=x
-((x
>>1)&0x55555555);
1902 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1903 x
=(x
+(x
>>4))&0x0f0f0f0f;
1905 return (x
+(x
>>16)) & 0xff;
1908 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1909 (SCM b
, SCM bitvector
),
1910 "Return the number of occurrences of the boolean @var{b} in\n"
1912 #define FUNC_NAME s_scm_bit_count
1914 scm_t_array_handle handle
;
1918 int bit
= scm_to_bool (b
);
1921 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1924 if (off
== 0 && inc
== 1 && len
> 0)
1928 size_t word_len
= (len
+ 31) / 32;
1929 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1932 for (i
= 0; i
< word_len
-1; i
++)
1933 count
+= count_ones (bits
[i
]);
1934 count
+= count_ones (bits
[i
] & last_mask
);
1939 for (i
= 0; i
< len
; i
++)
1940 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1944 scm_array_handle_release (&handle
);
1946 return scm_from_size_t (bit
? count
: len
-count
);
1950 /* returns 32 for x == 0.
1953 find_first_one (scm_t_uint32 x
)
1956 /* do a binary search in x. */
1957 if ((x
& 0xFFFF) == 0)
1958 x
>>= 16, pos
+= 16;
1959 if ((x
& 0xFF) == 0)
1970 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1971 (SCM item
, SCM v
, SCM k
),
1972 "Return the index of the first occurrance of @var{item} in bit\n"
1973 "vector @var{v}, starting from @var{k}. If there is no\n"
1974 "@var{item} entry between @var{k} and the end of\n"
1975 "@var{bitvector}, then return @code{#f}. For example,\n"
1978 "(bit-position #t #*000101 0) @result{} 3\n"
1979 "(bit-position #f #*0001111 3) @result{} #f\n"
1981 #define FUNC_NAME s_scm_bit_position
1983 scm_t_array_handle handle
;
1984 size_t off
, len
, first_bit
;
1986 const scm_t_uint32
*bits
;
1987 int bit
= scm_to_bool (item
);
1988 SCM res
= SCM_BOOL_F
;
1990 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1991 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1993 if (off
== 0 && inc
== 1 && len
> 0)
1995 size_t i
, word_len
= (len
+ 31) / 32;
1996 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1997 size_t first_word
= first_bit
/ 32;
1998 scm_t_uint32 first_mask
=
1999 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
2002 for (i
= first_word
; i
< word_len
; i
++)
2004 w
= (bit
? bits
[i
] : ~bits
[i
]);
2005 if (i
== first_word
)
2007 if (i
== word_len
-1)
2011 res
= scm_from_size_t (32*i
+ find_first_one (w
));
2019 for (i
= first_bit
; i
< len
; i
++)
2021 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
2022 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2024 res
= scm_from_size_t (i
);
2030 scm_array_handle_release (&handle
);
2036 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
2037 (SCM v
, SCM kv
, SCM obj
),
2038 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
2039 "selecting the entries to change. The return value is\n"
2042 "If @var{kv} is a bit vector, then those entries where it has\n"
2043 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
2044 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
2045 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
2046 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
2049 "(define bv #*01000010)\n"
2050 "(bit-set*! bv #*10010001 #t)\n"
2052 "@result{} #*11010011\n"
2055 "If @var{kv} is a u32vector, then its elements are\n"
2056 "indices into @var{v} which are set to @var{obj}.\n"
2059 "(define bv #*01000010)\n"
2060 "(bit-set*! bv #u32(5 2 7) #t)\n"
2062 "@result{} #*01100111\n"
2064 #define FUNC_NAME s_scm_bit_set_star_x
2066 scm_t_array_handle v_handle
;
2067 size_t v_off
, v_len
;
2069 scm_t_uint32
*v_bits
;
2072 /* Validate that OBJ is a boolean so this is done even if we don't
2075 bit
= scm_to_bool (obj
);
2077 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2078 &v_off
, &v_len
, &v_inc
);
2080 if (scm_is_bitvector (kv
))
2082 scm_t_array_handle kv_handle
;
2083 size_t kv_off
, kv_len
;
2085 const scm_t_uint32
*kv_bits
;
2087 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2088 &kv_off
, &kv_len
, &kv_inc
);
2090 if (v_len
!= kv_len
)
2091 scm_misc_error (NULL
,
2092 "bit vectors must have equal length",
2095 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2097 size_t word_len
= (kv_len
+ 31) / 32;
2098 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2103 for (i
= 0; i
< word_len
-1; i
++)
2104 v_bits
[i
] &= ~kv_bits
[i
];
2105 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2109 for (i
= 0; i
< word_len
-1; i
++)
2110 v_bits
[i
] |= kv_bits
[i
];
2111 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2117 for (i
= 0; i
< kv_len
; i
++)
2118 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2119 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2122 scm_array_handle_release (&kv_handle
);
2125 else if (scm_is_true (scm_u32vector_p (kv
)))
2127 scm_t_array_handle kv_handle
;
2130 const scm_t_uint32
*kv_elts
;
2132 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2133 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2134 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2136 scm_array_handle_release (&kv_handle
);
2139 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2141 scm_array_handle_release (&v_handle
);
2143 return SCM_UNSPECIFIED
;
2148 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2149 (SCM v
, SCM kv
, SCM obj
),
2150 "Return a count of how many entries in bit vector @var{v} are\n"
2151 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2154 "If @var{kv} is a bit vector, then those entries where it has\n"
2155 "@code{#t} are the ones in @var{v} which are considered.\n"
2156 "@var{kv} and @var{v} must be the same length.\n"
2158 "If @var{kv} is a u32vector, then it contains\n"
2159 "the indexes in @var{v} to consider.\n"
2164 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2165 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2167 #define FUNC_NAME s_scm_bit_count_star
2169 scm_t_array_handle v_handle
;
2170 size_t v_off
, v_len
;
2172 const scm_t_uint32
*v_bits
;
2176 /* Validate that OBJ is a boolean so this is done even if we don't
2179 bit
= scm_to_bool (obj
);
2181 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2182 &v_off
, &v_len
, &v_inc
);
2184 if (scm_is_bitvector (kv
))
2186 scm_t_array_handle kv_handle
;
2187 size_t kv_off
, kv_len
;
2189 const scm_t_uint32
*kv_bits
;
2191 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2192 &kv_off
, &kv_len
, &kv_inc
);
2194 if (v_len
!= kv_len
)
2195 scm_misc_error (NULL
,
2196 "bit vectors must have equal length",
2199 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2201 size_t i
, word_len
= (kv_len
+ 31) / 32;
2202 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2203 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2205 for (i
= 0; i
< word_len
-1; i
++)
2206 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2207 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2212 for (i
= 0; i
< kv_len
; i
++)
2213 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2215 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2216 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2221 scm_array_handle_release (&kv_handle
);
2224 else if (scm_is_true (scm_u32vector_p (kv
)))
2226 scm_t_array_handle kv_handle
;
2229 const scm_t_uint32
*kv_elts
;
2231 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2232 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2234 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2235 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2239 scm_array_handle_release (&kv_handle
);
2242 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2244 scm_array_handle_release (&v_handle
);
2246 return scm_from_size_t (count
);
2250 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2252 "Modify the bit vector @var{v} by replacing each element with\n"
2254 #define FUNC_NAME s_scm_bit_invert_x
2256 scm_t_array_handle handle
;
2261 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2263 if (off
== 0 && inc
== 1 && len
> 0)
2265 size_t word_len
= (len
+ 31) / 32;
2266 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2269 for (i
= 0; i
< word_len
-1; i
++)
2271 bits
[i
] = bits
[i
] ^ last_mask
;
2276 for (i
= 0; i
< len
; i
++)
2277 scm_array_handle_set (&handle
, i
*inc
,
2278 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2281 scm_array_handle_release (&handle
);
2283 return SCM_UNSPECIFIED
;
2289 scm_istr2bve (SCM str
)
2291 scm_t_array_handle handle
;
2292 size_t len
= scm_i_string_length (str
);
2293 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2301 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2302 c_str
= scm_i_string_chars (str
);
2304 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2310 for (mask
= 1L; j
--; mask
<<= 1)
2325 scm_array_handle_release (&handle
);
2326 scm_remember_upto_here_1 (str
);
2333 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2338 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
2340 if (k
== SCM_ARRAY_NDIM (ra
))
2341 return scm_i_cvref (SCM_ARRAY_V (ra
), base
, enclosed
);
2343 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2344 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2346 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2350 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2357 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2359 "Return a list consisting of all the elements, in order, of\n"
2361 #define FUNC_NAME s_scm_array_to_list
2363 if (scm_is_generalized_vector (v
))
2364 return scm_generalized_vector_to_list (v
);
2365 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
2366 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2368 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2373 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2375 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2376 (SCM type
, SCM ndim
, SCM lst
),
2377 "Return an array of the type @var{type}\n"
2378 "with elements the same as those of @var{lst}.\n"
2380 "The argument @var{ndim} determines the number of dimensions\n"
2381 "of the array. It is either an exact integer, giving the\n"
2382 "number directly, or a list of exact integers, whose length\n"
2383 "specifies the number of dimensions and each element is the\n"
2384 "lower index bound of its dimension.")
2385 #define FUNC_NAME s_scm_list_to_typed_array
2389 scm_t_array_handle handle
;
2393 if (scm_is_integer (ndim
))
2395 size_t k
= scm_to_size_t (ndim
);
2398 shape
= scm_cons (scm_length (row
), shape
);
2400 row
= scm_car (row
);
2407 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
2408 scm_sum (scm_sum (scm_car (ndim
),
2410 scm_from_int (-1))),
2412 ndim
= scm_cdr (ndim
);
2413 if (scm_is_pair (ndim
))
2414 row
= scm_car (row
);
2420 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2421 scm_reverse_x (shape
, SCM_EOL
));
2423 scm_array_get_handle (ra
, &handle
);
2424 l2ra (lst
, &handle
, 0, 0);
2425 scm_array_handle_release (&handle
);
2431 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2432 (SCM ndim
, SCM lst
),
2433 "Return an array with elements the same as those of @var{lst}.")
2434 #define FUNC_NAME s_scm_list_to_array
2436 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2441 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2443 if (k
== scm_array_handle_rank (handle
))
2444 scm_array_handle_set (handle
, pos
, lst
);
2447 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2448 ssize_t inc
= dim
->inc
;
2449 size_t n
= 1 + dim
->ubnd
- dim
->lbnd
;
2451 while (n
> 0 && scm_is_pair (lst
))
2453 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2455 lst
= SCM_CDR (lst
);
2459 scm_misc_error (NULL
, "too few elements for array dimension ~a",
2460 scm_list_1 (scm_from_ulong (k
)));
2461 if (!scm_is_null (lst
))
2462 scm_misc_error (NULL
, "too many elements for array dimension ~a",
2463 scm_list_1 (scm_from_ulong (k
)));
2467 #if SCM_ENABLE_DEPRECATED
2469 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2470 (SCM ndim
, SCM prot
, SCM lst
),
2471 "Return a uniform array of the type indicated by prototype\n"
2472 "@var{prot} with elements the same as those of @var{lst}.\n"
2473 "Elements must be of the appropriate type, no coercions are\n"
2476 "The argument @var{ndim} determines the number of dimensions\n"
2477 "of the array. It is either an exact integer, giving the\n"
2478 "number directly, or a list of exact integers, whose length\n"
2479 "specifies the number of dimensions and each element is the\n"
2480 "lower index bound of its dimension.")
2481 #define FUNC_NAME s_scm_list_to_uniform_array
2483 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2489 /* Print dimension DIM of ARRAY.
2493 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2494 SCM port
, scm_print_state
*pstate
)
2496 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
2499 scm_putc ('(', port
);
2501 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2503 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2504 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2507 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
2509 if (idx
< dim_spec
->ubnd
)
2510 scm_putc (' ', port
);
2511 base
+= dim_spec
->inc
;
2514 scm_putc (')', port
);
2518 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2522 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2524 long ndim
= SCM_ARRAY_NDIM (array
);
2525 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2526 SCM v
= SCM_ARRAY_V (array
);
2527 unsigned long base
= SCM_ARRAY_BASE (array
);
2530 scm_putc ('#', port
);
2531 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2532 scm_intprint (ndim
, 10, port
);
2533 if (scm_is_uniform_vector (v
))
2534 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2535 else if (scm_is_bitvector (v
))
2536 scm_puts ("b", port
);
2537 else if (scm_is_string (v
))
2538 scm_puts ("a", port
);
2539 else if (!scm_is_vector (v
))
2540 scm_puts ("?", port
);
2542 for (i
= 0; i
< ndim
; i
++)
2543 if (dim_specs
[i
].lbnd
!= 0)
2545 for (i
= 0; i
< ndim
; i
++)
2547 scm_putc ('@', port
);
2548 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2555 /* Rank zero arrays, which are really just scalars, are printed
2556 specially. The consequent way would be to print them as
2560 where OBJ is the printed representation of the scalar, but we
2561 print them instead as
2565 to make them look less strange.
2567 Just printing them as
2571 would be correct in a way as well, but zero rank arrays are
2572 not really the same as Scheme values since they are boxed and
2573 can be modified with array-set!, say.
2575 scm_putc ('(', port
);
2576 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2577 scm_putc (')', port
);
2581 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2585 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2589 scm_putc ('#', port
);
2590 base
= SCM_ARRAY_BASE (array
);
2591 scm_puts ("<enclosed-array ", port
);
2592 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2593 scm_putc ('>', port
);
2597 /* Read an array. This function can also read vectors and uniform
2598 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2601 C is the first character read after the '#'.
2605 tag_to_type (const char *tag
, SCM port
)
2607 #if SCM_ENABLE_DEPRECATED
2609 /* Recognize the old syntax.
2611 const char *instead
;
2643 if (instead
&& tag
[1] == '\0')
2645 scm_c_issue_deprecation_warning_fmt
2646 ("The tag '%c' is deprecated for uniform vectors. "
2647 "Use '%s' instead.", tag
[0], instead
);
2648 return scm_from_locale_symbol (instead
);
2656 return scm_from_locale_symbol (tag
);
2660 scm_i_read_array (SCM port
, int c
)
2667 SCM lower_bounds
= SCM_BOOL_F
, elements
;
2669 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2670 the array code can not deal with zero-length dimensions yet, and
2671 we want to allow zero-length vectors, of course.
2675 scm_ungetc (c
, port
);
2676 return scm_vector (scm_read (port
));
2679 /* Disambiguate between '#f' and uniform floating point vectors.
2683 c
= scm_getc (port
);
2684 if (c
!= '3' && c
!= '6')
2687 scm_ungetc (c
, port
);
2694 goto continue_reading_tag
;
2700 while ('0' <= c
&& c
<= '9')
2702 rank
= 10*rank
+ c
-'0';
2704 c
= scm_getc (port
);
2711 continue_reading_tag
:
2712 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2715 c
= scm_getc (port
);
2717 tag
[tag_len
] = '\0';
2719 /* Read lower bounds. */
2722 lower_bounds
= SCM_EOL
;
2726 /* Yeah, right, we should use some ready-made integer parsing
2733 c
= scm_getc (port
);
2737 c
= scm_getc (port
);
2739 while ('0' <= c
&& c
<= '9')
2741 lbnd
= 10*lbnd
+ c
-'0';
2742 c
= scm_getc (port
);
2744 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2748 /* Read nested lists of elements.
2751 scm_i_input_error (NULL
, port
,
2752 "missing '(' in vector or array literal",
2754 scm_ungetc (c
, port
);
2755 elements
= scm_read (port
);
2757 if (scm_is_false (lower_bounds
))
2758 lower_bounds
= scm_from_size_t (rank
);
2759 else if (scm_ilength (lower_bounds
) != rank
)
2760 scm_i_input_error (NULL
, port
,
2761 "the number of lower bounds must match the array rank",
2764 /* Handle special print syntax of rank zero arrays; see
2765 scm_i_print_array for a rationale.
2768 elements
= scm_car (elements
);
2772 return scm_list_to_typed_array (tag_to_type (tag
, port
),
2778 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2780 scm_iprin1 (exp
, port
, pstate
);
2784 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2787 #define FUNC_NAME s_scm_array_type
2789 if (SCM_ARRAYP (ra
))
2790 return scm_i_generalized_vector_type (SCM_ARRAY_V (ra
));
2791 else if (scm_is_generalized_vector (ra
))
2792 return scm_i_generalized_vector_type (ra
);
2793 else if (SCM_ENCLOSED_ARRAYP (ra
))
2794 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2796 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2800 #if SCM_ENABLE_DEPRECATED
2802 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2804 "Return an object that would produce an array of the same type\n"
2805 "as @var{array}, if used as the @var{prototype} for\n"
2806 "@code{make-uniform-array}.")
2807 #define FUNC_NAME s_scm_array_prototype
2809 if (SCM_ARRAYP (ra
))
2810 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2811 else if (scm_is_generalized_vector (ra
))
2812 return scm_i_get_old_prototype (ra
);
2813 else if (SCM_ENCLOSED_ARRAYP (ra
))
2814 return SCM_UNSPECIFIED
;
2816 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2823 array_mark (SCM ptr
)
2825 return SCM_ARRAY_V (ptr
);
2829 array_free (SCM ptr
)
2831 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2832 (sizeof (scm_t_array
)
2833 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2841 scm_tc16_array
= scm_make_smob_type ("array", 0);
2842 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2843 scm_set_smob_free (scm_tc16_array
, array_free
);
2844 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2845 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2847 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2848 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2849 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2850 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2851 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2853 scm_add_feature ("array");
2855 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2856 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2857 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2858 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2860 init_type_creator_table ();
2862 #include "libguile/unif.x"