1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_i_tc16_array
;
83 scm_t_bits scm_i_tc16_enclosed_array
;
85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
86 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
88 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
90 typedef SCM
creator_proc (SCM len
, SCM fill
);
95 creator_proc
*creator
;
96 } type_creator_table
[] = {
97 { "a", SCM_UNSPECIFIED
, scm_make_string
},
98 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
99 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
100 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
101 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
102 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
103 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
104 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
105 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
106 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
107 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
108 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
109 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
110 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
115 init_type_creator_table ()
118 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
120 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
121 type_creator_table
[i
].type
= scm_permanent_object (sym
);
125 static creator_proc
*
126 type_to_creator (SCM type
)
130 if (scm_is_eq (type
, SCM_BOOL_T
))
131 return scm_make_vector
;
132 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
133 if (scm_is_eq (type
, type_creator_table
[i
].type
))
134 return type_creator_table
[i
].creator
;
136 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
140 make_typed_vector (SCM type
, size_t len
)
142 creator_proc
*creator
= type_to_creator (type
);
143 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
146 #if SCM_ENABLE_DEPRECATED
148 SCM_SYMBOL (scm_sym_s
, "s");
149 SCM_SYMBOL (scm_sym_l
, "l");
154 if (!SCM_REALP (obj
))
158 double x
= SCM_REAL_VALUE (obj
);
160 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
164 SCM_API
int scm_i_inump (SCM obj
);
165 SCM_API scm_t_signed_bits
scm_i_inum (SCM obj
);
168 prototype_to_type (SCM proto
)
170 const char *type_name
;
172 if (scm_is_eq (proto
, SCM_BOOL_T
))
174 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
176 else if (SCM_CHARP (proto
))
178 else if (scm_i_inump (proto
))
180 if (scm_i_inum (proto
) > 0)
185 else if (scm_is_eq (proto
, scm_sym_s
))
187 else if (scm_is_eq (proto
, scm_sym_l
))
189 else if (SCM_REALP (proto
)
190 || scm_is_true (scm_eqv_p (proto
,
191 scm_divide (scm_from_int (1),
199 else if (SCM_COMPLEXP (proto
))
201 else if (scm_is_null (proto
))
207 return scm_from_locale_symbol (type_name
);
213 scm_i_get_old_prototype (SCM uvec
)
215 if (scm_is_bitvector (uvec
))
217 else if (scm_is_string (uvec
))
218 return SCM_MAKE_CHAR ('a');
219 else if (scm_is_true (scm_s8vector_p (uvec
)))
220 return SCM_MAKE_CHAR ('\0');
221 else if (scm_is_true (scm_s16vector_p (uvec
)))
223 else if (scm_is_true (scm_u32vector_p (uvec
)))
224 return scm_from_int (1);
225 else if (scm_is_true (scm_s32vector_p (uvec
)))
226 return scm_from_int (-1);
227 else if (scm_is_true (scm_s64vector_p (uvec
)))
229 else if (scm_is_true (scm_f32vector_p (uvec
)))
230 return scm_from_double (1.0);
231 else if (scm_is_true (scm_f64vector_p (uvec
)))
232 return scm_divide (scm_from_int (1), scm_from_int (3));
233 else if (scm_is_true (scm_c64vector_p (uvec
)))
234 return scm_c_make_rectangular (0, 1);
235 else if (scm_is_vector (uvec
))
238 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
242 scm_make_uve (long k
, SCM prot
)
243 #define FUNC_NAME "scm_make_uve"
245 scm_c_issue_deprecation_warning
246 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
248 return make_typed_vector (prototype_to_type (prot
), k
);
255 scm_is_array (SCM obj
)
257 return (SCM_I_ENCLOSED_ARRAYP (obj
)
258 || SCM_I_ARRAYP (obj
)
259 || scm_is_generalized_vector (obj
));
263 scm_is_typed_array (SCM obj
, SCM type
)
265 if (SCM_I_ENCLOSED_ARRAYP (obj
))
267 /* Enclosed arrays are arrays but are not of any type.
272 /* Get storage vector.
274 if (SCM_I_ARRAYP (obj
))
275 obj
= SCM_I_ARRAY_V (obj
);
277 /* It must be a generalized vector (which includes vectors, strings, etc).
279 if (!scm_is_generalized_vector (obj
))
282 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
286 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
288 return scm_i_cvref (SCM_I_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
292 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
294 return ((const SCM
*)h
->elements
)[pos
];
298 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
301 if (SCM_I_ARRAYP (h
->array
))
302 return scm_c_string_ref (SCM_I_ARRAY_V (h
->array
), pos
);
304 return scm_c_string_ref (h
->array
, pos
);
308 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
310 pos
+= scm_array_handle_bit_elements_offset (h
);
312 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
316 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
320 if (SCM_I_ENCLOSED_ARRAYP (v
))
322 h
->ref
= enclosed_ref
;
323 return enclosed_ref (h
, pos
);
326 if (SCM_I_ARRAYP (v
))
327 v
= SCM_I_ARRAY_V (v
);
329 if (scm_is_vector (v
))
331 h
->elements
= scm_array_handle_elements (h
);
334 else if (scm_is_uniform_vector (v
))
336 h
->elements
= scm_array_handle_uniform_elements (h
);
337 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
339 else if (scm_is_string (v
))
343 else if (scm_is_bitvector (v
))
345 h
->elements
= scm_array_handle_bit_elements (h
);
346 h
->ref
= bitvector_ref
;
349 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
351 return h
->ref (h
, pos
);
355 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
357 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
361 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
363 ((SCM
*)h
->writable_elements
)[pos
] = val
;
367 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
370 if (SCM_I_ARRAYP (h
->array
))
371 return scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
373 return scm_c_string_set_x (h
->array
, pos
, val
);
377 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
380 pos
+= scm_array_handle_bit_elements_offset (h
);
381 mask
= 1l << (pos
% 32);
382 if (scm_to_bool (val
))
383 ((scm_t_uint32
*)h
->elements
)[pos
/32] |= mask
;
385 ((scm_t_uint32
*)h
->elements
)[pos
/32] &= ~mask
;
389 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
393 if (SCM_I_ENCLOSED_ARRAYP (v
))
395 h
->set
= enclosed_set
;
396 enclosed_set (h
, pos
, val
);
400 if (SCM_I_ARRAYP (v
))
401 v
= SCM_I_ARRAY_V (v
);
403 if (scm_is_vector (v
))
405 h
->writable_elements
= scm_array_handle_writable_elements (h
);
408 else if (scm_is_uniform_vector (v
))
410 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
411 h
->set
= scm_i_uniform_vector_set_proc (v
);
413 else if (scm_is_string (v
))
417 else if (scm_is_bitvector (v
))
419 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
420 h
->set
= bitvector_set
;
423 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
425 h
->set (h
, pos
, val
);
429 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
432 h
->ref
= memoize_ref
;
433 h
->set
= memoize_set
;
435 if (SCM_I_ARRAYP (array
) || SCM_I_ENCLOSED_ARRAYP (array
))
437 h
->dims
= SCM_I_ARRAY_DIMS (array
);
438 h
->base
= SCM_I_ARRAY_BASE (array
);
440 else if (scm_is_generalized_vector (array
))
443 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
449 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
453 scm_array_handle_release (scm_t_array_handle
*h
)
455 /* Nothing to do here until arrays need to be reserved for real.
460 scm_array_handle_rank (scm_t_array_handle
*h
)
462 if (SCM_I_ARRAYP (h
->array
) || SCM_I_ENCLOSED_ARRAYP (h
->array
))
463 return SCM_I_ARRAY_NDIM (h
->array
);
469 scm_array_handle_dims (scm_t_array_handle
*h
)
475 scm_array_handle_elements (scm_t_array_handle
*h
)
478 if (SCM_I_ARRAYP (vec
))
479 vec
= SCM_I_ARRAY_V (vec
);
480 if (SCM_I_IS_VECTOR (vec
))
481 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
482 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
486 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
489 if (SCM_I_ARRAYP (vec
))
490 vec
= SCM_I_ARRAY_V (vec
);
491 if (SCM_I_IS_VECTOR (vec
))
492 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
493 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
496 #if SCM_ENABLE_DEPRECATED
498 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
500 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
502 #define FUNC_NAME s_scm_array_p
504 if (!SCM_UNBNDP (prot
))
506 scm_c_issue_deprecation_warning
507 ("Using prototypes with `array?' is deprecated."
508 " Use `typed-array?' instead.");
510 return scm_typed_array_p (obj
, prototype_to_type (prot
));
513 return scm_from_bool (scm_is_array (obj
));
517 #else /* !SCM_ENABLE_DEPRECATED */
519 /* We keep the old 2-argument C prototype for a while although the old
520 PROT argument is always ignored now. C code should probably use
521 scm_is_array or scm_is_typed_array anyway.
524 static SCM
scm_i_array_p (SCM obj
);
526 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
528 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
530 #define FUNC_NAME s_scm_i_array_p
532 return scm_from_bool (scm_is_array (obj
));
537 scm_array_p (SCM obj
, SCM prot
)
539 return scm_from_bool (scm_is_array (obj
));
542 #endif /* !SCM_ENABLE_DEPRECATED */
545 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
547 "Return @code{#t} if the @var{obj} is an array of type\n"
548 "@var{type}, and @code{#f} if not.")
549 #define FUNC_NAME s_scm_typed_array_p
551 return scm_from_bool (scm_is_typed_array (obj
, type
));
556 scm_c_array_rank (SCM array
)
558 scm_t_array_handle handle
;
561 scm_array_get_handle (array
, &handle
);
562 res
= scm_array_handle_rank (&handle
);
563 scm_array_handle_release (&handle
);
567 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
569 "Return the number of dimensions of the array @var{array.}\n")
570 #define FUNC_NAME s_scm_array_rank
572 return scm_from_size_t (scm_c_array_rank (array
));
577 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
579 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
580 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
582 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
584 #define FUNC_NAME s_scm_array_dimensions
586 scm_t_array_handle handle
;
591 scm_array_get_handle (ra
, &handle
);
592 s
= scm_array_handle_dims (&handle
);
593 k
= scm_array_handle_rank (&handle
);
596 res
= scm_cons (s
[k
].lbnd
597 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
598 scm_from_ssize_t (s
[k
].ubnd
),
600 : scm_from_ssize_t (1 + s
[k
].ubnd
),
603 scm_array_handle_release (&handle
);
609 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
611 "Return the root vector of a shared array.")
612 #define FUNC_NAME s_scm_shared_array_root
614 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
615 return SCM_I_ARRAY_V (ra
);
616 else if (scm_is_generalized_vector (ra
))
618 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
623 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
625 "Return the root vector index of the first element in the array.")
626 #define FUNC_NAME s_scm_shared_array_offset
628 scm_t_array_handle handle
;
631 scm_array_get_handle (ra
, &handle
);
632 res
= scm_from_size_t (handle
.base
);
633 scm_array_handle_release (&handle
);
639 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
641 "For each dimension, return the distance between elements in the root vector.")
642 #define FUNC_NAME s_scm_shared_array_increments
644 scm_t_array_handle handle
;
649 scm_array_get_handle (ra
, &handle
);
650 k
= scm_array_handle_rank (&handle
);
651 s
= scm_array_handle_dims (&handle
);
653 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
654 scm_array_handle_release (&handle
);
660 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
662 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
664 size_t k
= scm_array_handle_rank (h
);
666 while (k
> 0 && scm_is_pair (indices
))
668 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
669 pos
+= (i
- s
->lbnd
) * s
->inc
;
672 indices
= SCM_CDR (indices
);
674 if (k
> 0 || !scm_is_null (indices
))
675 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
676 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
681 scm_i_make_ra (int ndim
, int enclosed
)
683 scm_t_bits tag
= enclosed
? scm_i_tc16_enclosed_array
: scm_i_tc16_array
;
685 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
686 scm_gc_malloc ((sizeof (scm_i_t_array
) +
687 ndim
* sizeof (scm_t_array_dim
)),
689 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
693 static char s_bad_spec
[] = "Bad scm_array dimension";
696 /* Increments will still need to be set. */
699 scm_i_shap2ra (SCM args
)
703 int ndim
= scm_ilength (args
);
705 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
707 ra
= scm_i_make_ra (ndim
, 0);
708 SCM_I_ARRAY_BASE (ra
) = 0;
709 s
= SCM_I_ARRAY_DIMS (ra
);
710 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
712 spec
= SCM_CAR (args
);
713 if (scm_is_integer (spec
))
715 if (scm_to_long (spec
) < 0)
716 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
718 s
->ubnd
= scm_to_long (spec
) - 1;
723 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
724 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
725 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
727 if (!scm_is_pair (sp
)
728 || !scm_is_integer (SCM_CAR (sp
))
729 || !scm_is_null (SCM_CDR (sp
)))
730 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
731 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
738 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
739 (SCM type
, SCM fill
, SCM bounds
),
740 "Create and return an array of type @var{type}.")
741 #define FUNC_NAME s_scm_make_typed_array
745 creator_proc
*creator
;
748 creator
= type_to_creator (type
);
749 ra
= scm_i_shap2ra (bounds
);
750 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
751 s
= SCM_I_ARRAY_DIMS (ra
);
752 k
= SCM_I_ARRAY_NDIM (ra
);
757 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
758 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
761 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
762 fill
= SCM_UNDEFINED
;
764 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
766 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
767 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
768 return SCM_I_ARRAY_V (ra
);
773 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
774 (SCM fill
, SCM bounds
),
775 "Create and return an array.")
776 #define FUNC_NAME s_scm_make_array
778 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
782 #if SCM_ENABLE_DEPRECATED
784 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
785 (SCM dims
, SCM prot
, SCM fill
),
786 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
787 "Create and return a uniform array or vector of type\n"
788 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
789 "length @var{length}. If @var{fill} is supplied, it's used to\n"
790 "fill the array, otherwise @var{prototype} is used.")
791 #define FUNC_NAME s_scm_dimensions_to_uniform_array
793 scm_c_issue_deprecation_warning
794 ("`dimensions->uniform-array' is deprecated. "
795 "Use `make-typed-array' instead.");
797 if (scm_is_integer (dims
))
798 dims
= scm_list_1 (dims
);
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_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_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
;
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
+ SCM_I_ARRAY_BASE (oldra
);
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
= SCM_I_ARRAY_NDIM (v
);
1154 scm_t_array_dim
*s
= SCM_I_ARRAY_DIMS (v
);
1160 if (!scm_is_pair (args
))
1161 SCM_WRONG_NUM_ARGS ();
1162 ind
= scm_to_long (SCM_CAR (args
));
1163 args
= SCM_CDR (args
);
1166 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1169 /* We do not stop the checking after finding a violation
1170 since we want to validate the type-correctness and
1171 number of arguments in any case.
1176 else if (scm_is_generalized_vector (v
))
1178 /* Since real arrays have been covered above, all generalized
1179 vectors are guaranteed to be zero-origin here.
1184 if (!scm_is_pair (args
))
1185 SCM_WRONG_NUM_ARGS ();
1186 ind
= scm_to_long (SCM_CAR (args
));
1187 args
= SCM_CDR (args
);
1188 res
= scm_from_bool (ind
>= 0
1189 && ind
< scm_c_generalized_vector_length (v
));
1192 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1194 if (!scm_is_null (args
))
1195 SCM_WRONG_NUM_ARGS ();
1202 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1206 int k
= SCM_I_ARRAY_NDIM (v
);
1207 SCM res
= scm_i_make_ra (k
, 0);
1208 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (v
);
1209 SCM_I_ARRAY_BASE (res
) = pos
;
1212 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= SCM_I_ARRAY_DIMS (v
)[k
].ubnd
;
1213 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= SCM_I_ARRAY_DIMS (v
)[k
].lbnd
;
1214 SCM_I_ARRAY_DIMS (res
)[k
].inc
= SCM_I_ARRAY_DIMS (v
)[k
].inc
;
1219 return scm_c_generalized_vector_ref (v
, pos
);
1222 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1224 "Return the element at the @code{(index1, index2)} element in\n"
1226 #define FUNC_NAME s_scm_array_ref
1228 scm_t_array_handle handle
;
1231 scm_array_get_handle (v
, &handle
);
1232 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
1233 scm_array_handle_release (&handle
);
1239 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1240 (SCM v
, SCM obj
, SCM args
),
1241 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1242 "@var{new-value}. The value returned by array-set! is unspecified.")
1243 #define FUNC_NAME s_scm_array_set_x
1245 scm_t_array_handle handle
;
1247 scm_array_get_handle (v
, &handle
);
1248 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
1249 scm_array_handle_release (&handle
);
1250 return SCM_UNSPECIFIED
;
1254 /* attempts to unroll an array into a one-dimensional array.
1255 returns the unrolled array or #f if it can't be done. */
1256 /* if strict is not SCM_UNDEFINED, return #f if returned array
1257 wouldn't have contiguous elements. */
1258 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1259 (SCM ra
, SCM strict
),
1260 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1261 "without changing their order (last subscript changing fastest), then\n"
1262 "@code{array-contents} returns that shared array, otherwise it returns\n"
1263 "@code{#f}. All arrays made by @var{make-array} and\n"
1264 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1265 "@var{make-shared-array} may not be.\n\n"
1266 "If the optional argument @var{strict} is provided, a shared array will\n"
1267 "be returned only if its elements are stored internally contiguous in\n"
1269 #define FUNC_NAME s_scm_array_contents
1273 if (scm_is_generalized_vector (ra
))
1276 if (SCM_I_ARRAYP (ra
))
1278 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
1279 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
1281 for (k
= 0; k
< ndim
; k
++)
1282 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1283 if (!SCM_UNBNDP (strict
))
1285 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1287 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1289 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
1290 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1297 SCM v
= SCM_I_ARRAY_V (ra
);
1298 size_t length
= scm_c_generalized_vector_length (v
);
1299 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
1303 sra
= scm_i_make_ra (1, 0);
1304 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
1305 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1306 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
1307 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
1308 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1311 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
1312 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1314 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1320 scm_ra2contig (SCM ra
, int copy
)
1325 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1326 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1327 k
= SCM_I_ARRAY_NDIM (ra
);
1328 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1330 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1332 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1333 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1334 0 == len
% SCM_LONG_BIT
))
1337 ret
= scm_i_make_ra (k
, 0);
1338 SCM_I_ARRAY_BASE (ret
) = 0;
1341 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1342 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1343 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1344 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1346 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1348 scm_array_copy_x (ra
, ret
);
1354 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1355 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1356 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1357 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1358 "binary objects from @var{port-or-fdes}.\n"
1359 "If an end of file is encountered,\n"
1360 "the objects up to that point are put into @var{ura}\n"
1361 "(starting at the beginning) and the remainder of the array is\n"
1363 "The optional arguments @var{start} and @var{end} allow\n"
1364 "a specified region of a vector (or linearized array) to be read,\n"
1365 "leaving the remainder of the vector unchanged.\n\n"
1366 "@code{uniform-array-read!} returns the number of objects read.\n"
1367 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1368 "returned by @code{(current-input-port)}.")
1369 #define FUNC_NAME s_scm_uniform_array_read_x
1371 if (SCM_UNBNDP (port_or_fd
))
1372 port_or_fd
= scm_current_input_port ();
1374 if (scm_is_uniform_vector (ura
))
1376 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1378 else if (SCM_I_ARRAYP (ura
))
1380 size_t base
, vlen
, cstart
, cend
;
1383 cra
= scm_ra2contig (ura
, 0);
1384 base
= SCM_I_ARRAY_BASE (cra
);
1385 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1386 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1390 if (!SCM_UNBNDP (start
))
1392 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1393 if (!SCM_UNBNDP (end
))
1394 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1397 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1398 scm_from_size_t (base
+ cstart
),
1399 scm_from_size_t (base
+ cend
));
1401 if (!scm_is_eq (cra
, ura
))
1402 scm_array_copy_x (cra
, ura
);
1405 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1406 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1408 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1412 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1413 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1414 "Writes all elements of @var{ura} as binary objects to\n"
1415 "@var{port-or-fdes}.\n\n"
1416 "The optional arguments @var{start}\n"
1417 "and @var{end} allow\n"
1418 "a specified region of a vector (or linearized array) to be written.\n\n"
1419 "The number of objects actually written is returned.\n"
1420 "@var{port-or-fdes} may be\n"
1421 "omitted, in which case it defaults to the value returned by\n"
1422 "@code{(current-output-port)}.")
1423 #define FUNC_NAME s_scm_uniform_array_write
1425 if (SCM_UNBNDP (port_or_fd
))
1426 port_or_fd
= scm_current_output_port ();
1428 if (scm_is_uniform_vector (ura
))
1430 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1432 else if (SCM_I_ARRAYP (ura
))
1434 size_t base
, vlen
, cstart
, cend
;
1437 cra
= scm_ra2contig (ura
, 1);
1438 base
= SCM_I_ARRAY_BASE (cra
);
1439 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1440 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1444 if (!SCM_UNBNDP (start
))
1446 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1447 if (!SCM_UNBNDP (end
))
1448 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1451 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1452 scm_from_size_t (base
+ cstart
),
1453 scm_from_size_t (base
+ cend
));
1457 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1458 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1460 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1467 static scm_t_bits scm_tc16_bitvector
;
1469 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1470 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1471 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1474 bitvector_free (SCM vec
)
1476 scm_gc_free (BITVECTOR_BITS (vec
),
1477 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1483 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1485 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1486 size_t word_len
= (bit_len
+31)/32;
1487 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1490 scm_puts ("#*", port
);
1491 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1493 scm_t_uint32 mask
= 1;
1494 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1495 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1502 bitvector_equalp (SCM vec1
, SCM vec2
)
1504 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1505 size_t word_len
= (bit_len
+ 31) / 32;
1506 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1507 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1508 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1510 /* compare lengths */
1511 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1513 /* avoid underflow in word_len-1 below. */
1516 /* compare full words */
1517 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1519 /* compare partial last words */
1520 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1526 scm_is_bitvector (SCM vec
)
1528 return IS_BITVECTOR (vec
);
1531 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1533 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1534 "return @code{#f}.")
1535 #define FUNC_NAME s_scm_bitvector_p
1537 return scm_from_bool (scm_is_bitvector (obj
));
1542 scm_c_make_bitvector (size_t len
, SCM fill
)
1544 size_t word_len
= (len
+ 31) / 32;
1548 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1550 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1552 if (!SCM_UNBNDP (fill
))
1553 scm_bitvector_fill_x (res
, fill
);
1558 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1559 (SCM len
, SCM fill
),
1560 "Create a new bitvector of length @var{len} and\n"
1561 "optionally initialize all elements to @var{fill}.")
1562 #define FUNC_NAME s_scm_make_bitvector
1564 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1568 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1570 "Create a new bitvector with the arguments as elements.")
1571 #define FUNC_NAME s_scm_bitvector
1573 return scm_list_to_bitvector (bits
);
1578 scm_c_bitvector_length (SCM vec
)
1580 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1581 return BITVECTOR_LENGTH (vec
);
1584 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1586 "Return the length of the bitvector @var{vec}.")
1587 #define FUNC_NAME s_scm_bitvector_length
1589 return scm_from_size_t (scm_c_bitvector_length (vec
));
1593 const scm_t_uint32
*
1594 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1596 return scm_array_handle_bit_writable_elements (h
);
1600 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1603 if (SCM_I_ARRAYP (vec
))
1604 vec
= SCM_I_ARRAY_V (vec
);
1605 if (IS_BITVECTOR (vec
))
1606 return BITVECTOR_BITS (vec
) + h
->base
/32;
1607 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1611 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1613 return h
->base
% 32;
1616 const scm_t_uint32
*
1617 scm_bitvector_elements (SCM vec
,
1618 scm_t_array_handle
*h
,
1623 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1628 scm_bitvector_writable_elements (SCM vec
,
1629 scm_t_array_handle
*h
,
1634 scm_generalized_vector_get_handle (vec
, h
);
1637 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1638 *offp
= scm_array_handle_bit_elements_offset (h
);
1639 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1642 return scm_array_handle_bit_writable_elements (h
);
1646 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1648 scm_t_array_handle handle
;
1649 const scm_t_uint32
*bits
;
1651 if (IS_BITVECTOR (vec
))
1653 if (idx
>= BITVECTOR_LENGTH (vec
))
1654 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1655 bits
= BITVECTOR_BITS(vec
);
1656 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1664 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1666 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1667 idx
= idx
*inc
+ off
;
1668 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1669 scm_array_handle_release (&handle
);
1674 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1676 "Return the element at index @var{idx} of the bitvector\n"
1678 #define FUNC_NAME s_scm_bitvector_ref
1680 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1685 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1687 scm_t_array_handle handle
;
1688 scm_t_uint32
*bits
, mask
;
1690 if (IS_BITVECTOR (vec
))
1692 if (idx
>= BITVECTOR_LENGTH (vec
))
1693 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1694 bits
= BITVECTOR_BITS(vec
);
1701 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1703 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1704 idx
= idx
*inc
+ off
;
1707 mask
= 1L << (idx
%32);
1708 if (scm_is_true (val
))
1709 bits
[idx
/32] |= mask
;
1711 bits
[idx
/32] &= ~mask
;
1713 if (!IS_BITVECTOR (vec
))
1714 scm_array_handle_release (&handle
);
1717 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1718 (SCM vec
, SCM idx
, SCM val
),
1719 "Set the element at index @var{idx} of the bitvector\n"
1720 "@var{vec} when @var{val} is true, else clear it.")
1721 #define FUNC_NAME s_scm_bitvector_set_x
1723 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1724 return SCM_UNSPECIFIED
;
1728 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1730 "Set all elements of the bitvector\n"
1731 "@var{vec} when @var{val} is true, else clear them.")
1732 #define FUNC_NAME s_scm_bitvector_fill_x
1734 scm_t_array_handle handle
;
1739 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1742 if (off
== 0 && inc
== 1 && len
> 0)
1746 size_t word_len
= (len
+ 31) / 32;
1747 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1749 if (scm_is_true (val
))
1751 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1752 bits
[word_len
-1] |= last_mask
;
1756 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1757 bits
[word_len
-1] &= ~last_mask
;
1763 for (i
= 0; i
< len
; i
++)
1764 scm_array_handle_set (&handle
, i
*inc
, val
);
1767 scm_array_handle_release (&handle
);
1769 return SCM_UNSPECIFIED
;
1773 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1775 "Return a new bitvector initialized with the elements\n"
1777 #define FUNC_NAME s_scm_list_to_bitvector
1779 size_t bit_len
= scm_to_size_t (scm_length (list
));
1780 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1781 size_t word_len
= (bit_len
+31)/32;
1782 scm_t_array_handle handle
;
1783 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1787 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1789 scm_t_uint32 mask
= 1;
1791 for (j
= 0; j
< 32 && j
< bit_len
;
1792 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1793 if (scm_is_true (SCM_CAR (list
)))
1797 scm_array_handle_release (&handle
);
1803 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1805 "Return a new list initialized with the elements\n"
1806 "of the bitvector @var{vec}.")
1807 #define FUNC_NAME s_scm_bitvector_to_list
1809 scm_t_array_handle handle
;
1815 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1818 if (off
== 0 && inc
== 1)
1822 size_t word_len
= (len
+ 31) / 32;
1825 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1827 scm_t_uint32 mask
= 1;
1828 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1829 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1835 for (i
= 0; i
< len
; i
++)
1836 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1839 scm_array_handle_release (&handle
);
1841 return scm_reverse_x (res
, SCM_EOL
);
1845 /* From mmix-arith.w by Knuth.
1847 Here's a fun way to count the number of bits in a tetrabyte.
1849 [This classical trick is called the ``Gillies--Miller method for
1850 sideways addition'' in {\sl The Preparation of Programs for an
1851 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1852 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1853 the tricks used here were suggested by Balbir Singh, Peter
1854 Rossmanith, and Stefan Schwoon.]
1858 count_ones (scm_t_uint32 x
)
1860 x
=x
-((x
>>1)&0x55555555);
1861 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1862 x
=(x
+(x
>>4))&0x0f0f0f0f;
1864 return (x
+(x
>>16)) & 0xff;
1867 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1868 (SCM b
, SCM bitvector
),
1869 "Return the number of occurrences of the boolean @var{b} in\n"
1871 #define FUNC_NAME s_scm_bit_count
1873 scm_t_array_handle handle
;
1877 int bit
= scm_to_bool (b
);
1880 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1883 if (off
== 0 && inc
== 1 && len
> 0)
1887 size_t word_len
= (len
+ 31) / 32;
1888 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1891 for (i
= 0; i
< word_len
-1; i
++)
1892 count
+= count_ones (bits
[i
]);
1893 count
+= count_ones (bits
[i
] & last_mask
);
1898 for (i
= 0; i
< len
; i
++)
1899 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1903 scm_array_handle_release (&handle
);
1905 return scm_from_size_t (bit
? count
: len
-count
);
1909 /* returns 32 for x == 0.
1912 find_first_one (scm_t_uint32 x
)
1915 /* do a binary search in x. */
1916 if ((x
& 0xFFFF) == 0)
1917 x
>>= 16, pos
+= 16;
1918 if ((x
& 0xFF) == 0)
1929 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1930 (SCM item
, SCM v
, SCM k
),
1931 "Return the index of the first occurrance of @var{item} in bit\n"
1932 "vector @var{v}, starting from @var{k}. If there is no\n"
1933 "@var{item} entry between @var{k} and the end of\n"
1934 "@var{bitvector}, then return @code{#f}. For example,\n"
1937 "(bit-position #t #*000101 0) @result{} 3\n"
1938 "(bit-position #f #*0001111 3) @result{} #f\n"
1940 #define FUNC_NAME s_scm_bit_position
1942 scm_t_array_handle handle
;
1943 size_t off
, len
, first_bit
;
1945 const scm_t_uint32
*bits
;
1946 int bit
= scm_to_bool (item
);
1947 SCM res
= SCM_BOOL_F
;
1949 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1950 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1952 if (off
== 0 && inc
== 1 && len
> 0)
1954 size_t i
, word_len
= (len
+ 31) / 32;
1955 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1956 size_t first_word
= first_bit
/ 32;
1957 scm_t_uint32 first_mask
=
1958 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1961 for (i
= first_word
; i
< word_len
; i
++)
1963 w
= (bit
? bits
[i
] : ~bits
[i
]);
1964 if (i
== first_word
)
1966 if (i
== word_len
-1)
1970 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1978 for (i
= first_bit
; i
< len
; i
++)
1980 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1981 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1983 res
= scm_from_size_t (i
);
1989 scm_array_handle_release (&handle
);
1995 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1996 (SCM v
, SCM kv
, SCM obj
),
1997 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1998 "selecting the entries to change. The return value is\n"
2001 "If @var{kv} is a bit vector, then those entries where it has\n"
2002 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
2003 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
2004 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
2005 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
2008 "(define bv #*01000010)\n"
2009 "(bit-set*! bv #*10010001 #t)\n"
2011 "@result{} #*11010011\n"
2014 "If @var{kv} is a u32vector, then its elements are\n"
2015 "indices into @var{v} which are set to @var{obj}.\n"
2018 "(define bv #*01000010)\n"
2019 "(bit-set*! bv #u32(5 2 7) #t)\n"
2021 "@result{} #*01100111\n"
2023 #define FUNC_NAME s_scm_bit_set_star_x
2025 scm_t_array_handle v_handle
;
2026 size_t v_off
, v_len
;
2028 scm_t_uint32
*v_bits
;
2031 /* Validate that OBJ is a boolean so this is done even if we don't
2034 bit
= scm_to_bool (obj
);
2036 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2037 &v_off
, &v_len
, &v_inc
);
2039 if (scm_is_bitvector (kv
))
2041 scm_t_array_handle kv_handle
;
2042 size_t kv_off
, kv_len
;
2044 const scm_t_uint32
*kv_bits
;
2046 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2047 &kv_off
, &kv_len
, &kv_inc
);
2049 if (v_len
!= kv_len
)
2050 scm_misc_error (NULL
,
2051 "bit vectors must have equal length",
2054 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2056 size_t word_len
= (kv_len
+ 31) / 32;
2057 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2062 for (i
= 0; i
< word_len
-1; i
++)
2063 v_bits
[i
] &= ~kv_bits
[i
];
2064 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2068 for (i
= 0; i
< word_len
-1; i
++)
2069 v_bits
[i
] |= kv_bits
[i
];
2070 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2076 for (i
= 0; i
< kv_len
; i
++)
2077 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2078 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2081 scm_array_handle_release (&kv_handle
);
2084 else if (scm_is_true (scm_u32vector_p (kv
)))
2086 scm_t_array_handle kv_handle
;
2089 const scm_t_uint32
*kv_elts
;
2091 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2092 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2093 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2095 scm_array_handle_release (&kv_handle
);
2098 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2100 scm_array_handle_release (&v_handle
);
2102 return SCM_UNSPECIFIED
;
2107 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2108 (SCM v
, SCM kv
, SCM obj
),
2109 "Return a count of how many entries in bit vector @var{v} are\n"
2110 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2113 "If @var{kv} is a bit vector, then those entries where it has\n"
2114 "@code{#t} are the ones in @var{v} which are considered.\n"
2115 "@var{kv} and @var{v} must be the same length.\n"
2117 "If @var{kv} is a u32vector, then it contains\n"
2118 "the indexes in @var{v} to consider.\n"
2123 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2124 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2126 #define FUNC_NAME s_scm_bit_count_star
2128 scm_t_array_handle v_handle
;
2129 size_t v_off
, v_len
;
2131 const scm_t_uint32
*v_bits
;
2135 /* Validate that OBJ is a boolean so this is done even if we don't
2138 bit
= scm_to_bool (obj
);
2140 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2141 &v_off
, &v_len
, &v_inc
);
2143 if (scm_is_bitvector (kv
))
2145 scm_t_array_handle kv_handle
;
2146 size_t kv_off
, kv_len
;
2148 const scm_t_uint32
*kv_bits
;
2150 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2151 &kv_off
, &kv_len
, &kv_inc
);
2153 if (v_len
!= kv_len
)
2154 scm_misc_error (NULL
,
2155 "bit vectors must have equal length",
2158 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2160 size_t i
, word_len
= (kv_len
+ 31) / 32;
2161 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2162 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2164 for (i
= 0; i
< word_len
-1; i
++)
2165 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2166 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2171 for (i
= 0; i
< kv_len
; i
++)
2172 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2174 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2175 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2180 scm_array_handle_release (&kv_handle
);
2183 else if (scm_is_true (scm_u32vector_p (kv
)))
2185 scm_t_array_handle kv_handle
;
2188 const scm_t_uint32
*kv_elts
;
2190 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2191 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2193 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2194 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2198 scm_array_handle_release (&kv_handle
);
2201 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2203 scm_array_handle_release (&v_handle
);
2205 return scm_from_size_t (count
);
2209 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2211 "Modify the bit vector @var{v} by replacing each element with\n"
2213 #define FUNC_NAME s_scm_bit_invert_x
2215 scm_t_array_handle handle
;
2220 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2222 if (off
== 0 && inc
== 1 && len
> 0)
2224 size_t word_len
= (len
+ 31) / 32;
2225 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2228 for (i
= 0; i
< word_len
-1; i
++)
2230 bits
[i
] = bits
[i
] ^ last_mask
;
2235 for (i
= 0; i
< len
; i
++)
2236 scm_array_handle_set (&handle
, i
*inc
,
2237 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2240 scm_array_handle_release (&handle
);
2242 return SCM_UNSPECIFIED
;
2248 scm_istr2bve (SCM str
)
2250 scm_t_array_handle handle
;
2251 size_t len
= scm_i_string_length (str
);
2252 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2260 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2261 c_str
= scm_i_string_chars (str
);
2263 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2269 for (mask
= 1L; j
--; mask
<<= 1)
2284 scm_array_handle_release (&handle
);
2285 scm_remember_upto_here_1 (str
);
2292 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2297 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2299 if (k
== SCM_I_ARRAY_NDIM (ra
))
2300 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2302 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2303 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2305 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2309 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2316 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2318 "Return a list consisting of all the elements, in order, of\n"
2320 #define FUNC_NAME s_scm_array_to_list
2322 if (scm_is_generalized_vector (v
))
2323 return scm_generalized_vector_to_list (v
);
2324 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2325 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2327 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2332 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2334 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2335 (SCM type
, SCM shape
, SCM lst
),
2336 "Return an array of the type @var{type}\n"
2337 "with elements the same as those of @var{lst}.\n"
2339 "The argument @var{shape} determines the number of dimensions\n"
2340 "of the array and their shape. It is either an exact integer,\n"
2342 "number of dimensions directly, or a list whose length\n"
2343 "specifies the number of dimensions and each element specified\n"
2344 "the lower and optionally the upper bound of the corresponding\n"
2346 "When the element is list of two elements, these elements\n"
2347 "give the lower and upper bounds. When it is an exact\n"
2348 "integer, it gives only the lower bound.")
2349 #define FUNC_NAME s_scm_list_to_typed_array
2353 scm_t_array_handle handle
;
2356 if (scm_is_integer (shape
))
2358 size_t k
= scm_to_size_t (shape
);
2362 shape
= scm_cons (scm_length (row
), shape
);
2363 if (k
> 0 && !scm_is_null (row
))
2364 row
= scm_car (row
);
2369 SCM shape_spec
= shape
;
2373 SCM spec
= scm_car (shape_spec
);
2374 if (scm_is_pair (spec
))
2375 shape
= scm_cons (spec
, shape
);
2377 shape
= scm_cons (scm_list_2 (spec
,
2378 scm_sum (scm_sum (spec
,
2380 scm_from_int (-1))),
2382 shape_spec
= scm_cdr (shape_spec
);
2383 if (scm_is_pair (shape_spec
))
2385 if (!scm_is_null (row
))
2386 row
= scm_car (row
);
2393 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2394 scm_reverse_x (shape
, SCM_EOL
));
2396 scm_array_get_handle (ra
, &handle
);
2397 l2ra (lst
, &handle
, 0, 0);
2398 scm_array_handle_release (&handle
);
2404 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2405 (SCM ndim
, SCM lst
),
2406 "Return an array with elements the same as those of @var{lst}.")
2407 #define FUNC_NAME s_scm_list_to_array
2409 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2414 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2416 if (k
== scm_array_handle_rank (handle
))
2417 scm_array_handle_set (handle
, pos
, lst
);
2420 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2421 ssize_t inc
= dim
->inc
;
2422 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2423 char *errmsg
= NULL
;
2426 while (n
> 0 && scm_is_pair (lst
))
2428 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2430 lst
= SCM_CDR (lst
);
2434 errmsg
= "too few elements for array dimension ~a, need ~a";
2435 if (!scm_is_null (lst
))
2436 errmsg
= "too many elements for array dimension ~a, want ~a";
2438 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2439 scm_from_size_t (len
)));
2443 #if SCM_ENABLE_DEPRECATED
2445 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2446 (SCM ndim
, SCM prot
, SCM lst
),
2447 "Return a uniform array of the type indicated by prototype\n"
2448 "@var{prot} with elements the same as those of @var{lst}.\n"
2449 "Elements must be of the appropriate type, no coercions are\n"
2452 "The argument @var{ndim} determines the number of dimensions\n"
2453 "of the array. It is either an exact integer, giving the\n"
2454 "number directly, or a list of exact integers, whose length\n"
2455 "specifies the number of dimensions and each element is the\n"
2456 "lower index bound of its dimension.")
2457 #define FUNC_NAME s_scm_list_to_uniform_array
2459 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2465 /* Print dimension DIM of ARRAY.
2469 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2470 SCM port
, scm_print_state
*pstate
)
2472 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2475 scm_putc ('(', port
);
2477 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2479 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2480 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2483 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2485 if (idx
< dim_spec
->ubnd
)
2486 scm_putc (' ', port
);
2487 base
+= dim_spec
->inc
;
2490 scm_putc (')', port
);
2494 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2498 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2500 long ndim
= SCM_I_ARRAY_NDIM (array
);
2501 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2502 SCM v
= SCM_I_ARRAY_V (array
);
2503 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2505 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2507 scm_putc ('#', port
);
2508 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2509 scm_intprint (ndim
, 10, port
);
2510 if (scm_is_uniform_vector (v
))
2511 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2512 else if (scm_is_bitvector (v
))
2513 scm_puts ("b", port
);
2514 else if (scm_is_string (v
))
2515 scm_puts ("a", port
);
2516 else if (!scm_is_vector (v
))
2517 scm_puts ("?", port
);
2519 for (i
= 0; i
< ndim
; i
++)
2521 if (dim_specs
[i
].lbnd
!= 0)
2523 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2529 if (print_lbnds
|| print_lens
)
2530 for (i
= 0; i
< ndim
; i
++)
2534 scm_putc ('@', port
);
2535 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2539 scm_putc (':', port
);
2540 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2547 /* Rank zero arrays, which are really just scalars, are printed
2548 specially. The consequent way would be to print them as
2552 where OBJ is the printed representation of the scalar, but we
2553 print them instead as
2557 to make them look less strange.
2559 Just printing them as
2563 would be correct in a way as well, but zero rank arrays are
2564 not really the same as Scheme values since they are boxed and
2565 can be modified with array-set!, say.
2567 scm_putc ('(', port
);
2568 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2569 scm_putc (')', port
);
2573 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2577 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2581 scm_putc ('#', port
);
2582 base
= SCM_I_ARRAY_BASE (array
);
2583 scm_puts ("<enclosed-array ", port
);
2584 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2585 scm_putc ('>', port
);
2589 /* Read an array. This function can also read vectors and uniform
2590 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2593 C is the first character read after the '#'.
2597 tag_to_type (const char *tag
, SCM port
)
2599 #if SCM_ENABLE_DEPRECATED
2601 /* Recognize the old syntax.
2603 const char *instead
;
2635 if (instead
&& tag
[1] == '\0')
2637 scm_c_issue_deprecation_warning_fmt
2638 ("The tag '%c' is deprecated for uniform vectors. "
2639 "Use '%s' instead.", tag
[0], instead
);
2640 return scm_from_locale_symbol (instead
);
2648 return scm_from_locale_symbol (tag
);
2652 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2661 c
= scm_getc (port
);
2664 while ('0' <= c
&& c
<= '9')
2666 res
= 10*res
+ c
-'0';
2668 c
= scm_getc (port
);
2677 scm_i_read_array (SCM port
, int c
)
2684 SCM shape
= SCM_BOOL_F
, elements
;
2686 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2687 the array code can not deal with zero-length dimensions yet, and
2688 we want to allow zero-length vectors, of course.
2692 scm_ungetc (c
, port
);
2693 return scm_vector (scm_read (port
));
2696 /* Disambiguate between '#f' and uniform floating point vectors.
2700 c
= scm_getc (port
);
2701 if (c
!= '3' && c
!= '6')
2704 scm_ungetc (c
, port
);
2711 goto continue_reading_tag
;
2717 c
= read_decimal_integer (port
, c
, &rank
);
2719 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2725 continue_reading_tag
:
2726 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2729 c
= scm_getc (port
);
2731 tag
[tag_len
] = '\0';
2735 if (c
== '@' || c
== ':')
2741 ssize_t lbnd
= 0, len
= 0;
2746 c
= scm_getc (port
);
2747 c
= read_decimal_integer (port
, c
, &lbnd
);
2750 s
= scm_from_ssize_t (lbnd
);
2754 c
= scm_getc (port
);
2755 c
= read_decimal_integer (port
, c
, &len
);
2756 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2759 shape
= scm_cons (s
, shape
);
2760 } while (c
== '@' || c
== ':');
2762 shape
= scm_reverse_x (shape
, SCM_EOL
);
2765 /* Read nested lists of elements.
2768 scm_i_input_error (NULL
, port
,
2769 "missing '(' in vector or array literal",
2771 scm_ungetc (c
, port
);
2772 elements
= scm_read (port
);
2774 if (scm_is_false (shape
))
2775 shape
= scm_from_ssize_t (rank
);
2776 else if (scm_ilength (shape
) != rank
)
2779 "the number of shape specifications must match the array rank",
2782 /* Handle special print syntax of rank zero arrays; see
2783 scm_i_print_array for a rationale.
2787 if (!scm_is_pair (elements
))
2788 scm_i_input_error (NULL
, port
,
2789 "too few elements in array literal, need 1",
2791 if (!scm_is_null (SCM_CDR (elements
)))
2792 scm_i_input_error (NULL
, port
,
2793 "too many elements in array literal, want 1",
2795 elements
= SCM_CAR (elements
);
2800 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2803 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2806 #define FUNC_NAME s_scm_array_type
2808 if (SCM_I_ARRAYP (ra
))
2809 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2810 else if (scm_is_generalized_vector (ra
))
2811 return scm_i_generalized_vector_type (ra
);
2812 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2813 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2815 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2819 #if SCM_ENABLE_DEPRECATED
2821 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2823 "Return an object that would produce an array of the same type\n"
2824 "as @var{array}, if used as the @var{prototype} for\n"
2825 "@code{make-uniform-array}.")
2826 #define FUNC_NAME s_scm_array_prototype
2828 if (SCM_I_ARRAYP (ra
))
2829 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2830 else if (scm_is_generalized_vector (ra
))
2831 return scm_i_get_old_prototype (ra
);
2832 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2833 return SCM_UNSPECIFIED
;
2835 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2842 array_mark (SCM ptr
)
2844 return SCM_I_ARRAY_V (ptr
);
2848 array_free (SCM ptr
)
2850 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
2851 (sizeof (scm_i_t_array
)
2852 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2857 #if SCM_ENABLE_DEPRECATED
2860 scm_make_ra (int ndim
)
2862 scm_c_issue_deprecation_warning
2863 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2864 return scm_i_make_ra (ndim
, 0);
2868 scm_shap2ra (SCM args
, const char *what
)
2870 scm_c_issue_deprecation_warning
2871 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2872 return scm_i_shap2ra (args
);
2876 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2878 scm_c_issue_deprecation_warning
2879 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2880 return scm_c_generalized_vector_ref (v
, pos
);
2884 scm_ra_set_contp (SCM ra
)
2886 scm_c_issue_deprecation_warning
2887 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2888 scm_i_ra_set_contp (ra
);
2892 scm_aind (SCM ra
, SCM args
, const char *what
)
2894 scm_t_array_handle handle
;
2897 scm_c_issue_deprecation_warning
2898 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2900 if (scm_is_integer (args
))
2901 args
= scm_list_1 (args
);
2903 scm_array_get_handle (ra
, &handle
);
2904 pos
= scm_array_handle_pos (&handle
, args
) + SCM_I_ARRAY_BASE (ra
);
2905 scm_array_handle_release (&handle
);
2910 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2912 scm_c_issue_deprecation_warning
2913 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2915 scm_iprin1 (exp
, port
, pstate
);
2924 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2925 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
2926 scm_set_smob_free (scm_i_tc16_array
, array_free
);
2927 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2928 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2930 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2931 scm_set_smob_mark (scm_i_tc16_enclosed_array
, array_mark
);
2932 scm_set_smob_free (scm_i_tc16_enclosed_array
, array_free
);
2933 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2934 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2936 scm_add_feature ("array");
2938 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2939 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2940 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2941 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2943 init_type_creator_table ();
2945 #include "libguile/unif.x"