1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_i_tc16_array
;
83 scm_t_bits scm_i_tc16_enclosed_array
;
85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
86 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
88 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
90 typedef SCM
creator_proc (SCM len
, SCM fill
);
95 creator_proc
*creator
;
96 } type_creator_table
[] = {
97 { "a", SCM_UNSPECIFIED
, scm_make_string
},
98 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
99 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
100 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
101 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
102 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
103 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
104 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
105 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
106 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
107 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
108 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
109 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
110 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
115 init_type_creator_table ()
118 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
120 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
121 type_creator_table
[i
].type
= scm_permanent_object (sym
);
125 static creator_proc
*
126 type_to_creator (SCM type
)
130 if (scm_is_eq (type
, SCM_BOOL_T
))
131 return scm_make_vector
;
132 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
133 if (scm_is_eq (type
, type_creator_table
[i
].type
))
134 return type_creator_table
[i
].creator
;
136 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
140 make_typed_vector (SCM type
, size_t len
)
142 creator_proc
*creator
= type_to_creator (type
);
143 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
146 #if SCM_ENABLE_DEPRECATED
148 SCM_SYMBOL (scm_sym_s
, "s");
149 SCM_SYMBOL (scm_sym_l
, "l");
154 if (!SCM_REALP (obj
))
158 double x
= SCM_REAL_VALUE (obj
);
160 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
164 SCM_API
int scm_i_inump (SCM obj
);
165 SCM_API scm_t_signed_bits
scm_i_inum (SCM obj
);
168 prototype_to_type (SCM proto
)
170 const char *type_name
;
172 if (scm_is_eq (proto
, SCM_BOOL_T
))
174 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
176 else if (SCM_CHARP (proto
))
178 else if (scm_i_inump (proto
))
180 if (scm_i_inum (proto
) > 0)
185 else if (scm_is_eq (proto
, scm_sym_s
))
187 else if (scm_is_eq (proto
, scm_sym_l
))
189 else if (SCM_REALP (proto
)
190 || scm_is_true (scm_eqv_p (proto
,
191 scm_divide (scm_from_int (1),
199 else if (SCM_COMPLEXP (proto
))
201 else if (scm_is_null (proto
))
207 return scm_from_locale_symbol (type_name
);
213 scm_i_get_old_prototype (SCM uvec
)
215 if (scm_is_bitvector (uvec
))
217 else if (scm_is_string (uvec
))
218 return SCM_MAKE_CHAR ('a');
219 else if (scm_is_true (scm_s8vector_p (uvec
)))
220 return SCM_MAKE_CHAR ('\0');
221 else if (scm_is_true (scm_s16vector_p (uvec
)))
223 else if (scm_is_true (scm_u32vector_p (uvec
)))
224 return scm_from_int (1);
225 else if (scm_is_true (scm_s32vector_p (uvec
)))
226 return scm_from_int (-1);
227 else if (scm_is_true (scm_s64vector_p (uvec
)))
229 else if (scm_is_true (scm_f32vector_p (uvec
)))
230 return scm_from_double (1.0);
231 else if (scm_is_true (scm_f64vector_p (uvec
)))
232 return scm_divide (scm_from_int (1), scm_from_int (3));
233 else if (scm_is_true (scm_c64vector_p (uvec
)))
234 return scm_c_make_rectangular (0, 1);
235 else if (scm_is_vector (uvec
))
238 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
242 scm_make_uve (long k
, SCM prot
)
243 #define FUNC_NAME "scm_make_uve"
245 scm_c_issue_deprecation_warning
246 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
248 return make_typed_vector (prototype_to_type (prot
), k
);
255 scm_is_array (SCM obj
)
257 return (SCM_I_ENCLOSED_ARRAYP (obj
)
258 || SCM_I_ARRAYP (obj
)
259 || scm_is_generalized_vector (obj
));
263 scm_is_typed_array (SCM obj
, SCM type
)
265 if (SCM_I_ENCLOSED_ARRAYP (obj
))
267 /* Enclosed arrays are arrays but are not of any type.
272 /* Get storage vector.
274 if (SCM_I_ARRAYP (obj
))
275 obj
= SCM_I_ARRAY_V (obj
);
277 /* It must be a generalized vector (which includes vectors, strings, etc).
279 if (!scm_is_generalized_vector (obj
))
282 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
286 enclosed_ref (scm_t_array_handle
*h
, ssize_t pos
)
288 return scm_i_cvref (SCM_I_ARRAY_V (h
->array
), pos
+ h
->base
, 1);
292 vector_ref (scm_t_array_handle
*h
, ssize_t pos
)
294 return ((const SCM
*)h
->elements
)[pos
];
298 string_ref (scm_t_array_handle
*h
, ssize_t pos
)
301 if (SCM_I_ARRAYP (h
->array
))
302 return scm_c_string_ref (SCM_I_ARRAY_V (h
->array
), pos
);
304 return scm_c_string_ref (h
->array
, pos
);
308 bitvector_ref (scm_t_array_handle
*h
, ssize_t pos
)
310 pos
+= scm_array_handle_bit_elements_offset (h
);
312 scm_from_bool (((scm_t_uint32
*)h
->elements
)[pos
/32] & (1l << (pos
% 32)));
316 memoize_ref (scm_t_array_handle
*h
, ssize_t pos
)
320 if (SCM_I_ENCLOSED_ARRAYP (v
))
322 h
->ref
= enclosed_ref
;
323 return enclosed_ref (h
, pos
);
326 if (SCM_I_ARRAYP (v
))
327 v
= SCM_I_ARRAY_V (v
);
329 if (scm_is_vector (v
))
331 h
->elements
= scm_array_handle_elements (h
);
334 else if (scm_is_uniform_vector (v
))
336 h
->elements
= scm_array_handle_uniform_elements (h
);
337 h
->ref
= scm_i_uniform_vector_ref_proc (v
);
339 else if (scm_is_string (v
))
343 else if (scm_is_bitvector (v
))
345 h
->elements
= scm_array_handle_bit_elements (h
);
346 h
->ref
= bitvector_ref
;
349 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
351 return h
->ref (h
, pos
);
355 enclosed_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
357 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
361 vector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
363 ((SCM
*)h
->writable_elements
)[pos
] = val
;
367 string_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
370 if (SCM_I_ARRAYP (h
->array
))
371 scm_c_string_set_x (SCM_I_ARRAY_V (h
->array
), pos
, val
);
373 scm_c_string_set_x (h
->array
, pos
, val
);
377 bitvector_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
380 pos
+= scm_array_handle_bit_elements_offset (h
);
381 mask
= 1l << (pos
% 32);
382 if (scm_to_bool (val
))
383 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] |= mask
;
385 ((scm_t_uint32
*)h
->writable_elements
)[pos
/32] &= ~mask
;
389 memoize_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
393 if (SCM_I_ENCLOSED_ARRAYP (v
))
395 h
->set
= enclosed_set
;
396 enclosed_set (h
, pos
, val
);
400 if (SCM_I_ARRAYP (v
))
401 v
= SCM_I_ARRAY_V (v
);
403 if (scm_is_vector (v
))
405 h
->writable_elements
= scm_array_handle_writable_elements (h
);
408 else if (scm_is_uniform_vector (v
))
410 h
->writable_elements
= scm_array_handle_uniform_writable_elements (h
);
411 h
->set
= scm_i_uniform_vector_set_proc (v
);
413 else if (scm_is_string (v
))
417 else if (scm_is_bitvector (v
))
419 h
->writable_elements
= scm_array_handle_bit_writable_elements (h
);
420 h
->set
= bitvector_set
;
423 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (h
->array
));
425 h
->set (h
, pos
, val
);
429 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
432 h
->ref
= memoize_ref
;
433 h
->set
= memoize_set
;
435 if (SCM_I_ARRAYP (array
) || SCM_I_ENCLOSED_ARRAYP (array
))
437 h
->dims
= SCM_I_ARRAY_DIMS (array
);
438 h
->base
= SCM_I_ARRAY_BASE (array
);
440 else if (scm_is_generalized_vector (array
))
443 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
449 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
453 scm_array_handle_release (scm_t_array_handle
*h
)
455 /* Nothing to do here until arrays need to be reserved for real.
460 scm_array_handle_rank (scm_t_array_handle
*h
)
462 if (SCM_I_ARRAYP (h
->array
) || SCM_I_ENCLOSED_ARRAYP (h
->array
))
463 return SCM_I_ARRAY_NDIM (h
->array
);
469 scm_array_handle_dims (scm_t_array_handle
*h
)
475 scm_array_handle_elements (scm_t_array_handle
*h
)
478 if (SCM_I_ARRAYP (vec
))
479 vec
= SCM_I_ARRAY_V (vec
);
480 if (SCM_I_IS_VECTOR (vec
))
481 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
482 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
486 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
489 if (SCM_I_ARRAYP (vec
))
490 vec
= SCM_I_ARRAY_V (vec
);
491 if (SCM_I_IS_VECTOR (vec
))
492 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
493 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
496 #if SCM_ENABLE_DEPRECATED
498 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
500 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
502 #define FUNC_NAME s_scm_array_p
504 if (!SCM_UNBNDP (prot
))
506 scm_c_issue_deprecation_warning
507 ("Using prototypes with `array?' is deprecated."
508 " Use `typed-array?' instead.");
510 return scm_typed_array_p (obj
, prototype_to_type (prot
));
513 return scm_from_bool (scm_is_array (obj
));
517 #else /* !SCM_ENABLE_DEPRECATED */
519 /* We keep the old 2-argument C prototype for a while although the old
520 PROT argument is always ignored now. C code should probably use
521 scm_is_array or scm_is_typed_array anyway.
524 static SCM
scm_i_array_p (SCM obj
);
526 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
528 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
530 #define FUNC_NAME s_scm_i_array_p
532 return scm_from_bool (scm_is_array (obj
));
537 scm_array_p (SCM obj
, SCM prot
)
539 return scm_from_bool (scm_is_array (obj
));
542 #endif /* !SCM_ENABLE_DEPRECATED */
545 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
547 "Return @code{#t} if the @var{obj} is an array of type\n"
548 "@var{type}, and @code{#f} if not.")
549 #define FUNC_NAME s_scm_typed_array_p
551 return scm_from_bool (scm_is_typed_array (obj
, type
));
556 scm_c_array_rank (SCM array
)
558 scm_t_array_handle handle
;
561 scm_array_get_handle (array
, &handle
);
562 res
= scm_array_handle_rank (&handle
);
563 scm_array_handle_release (&handle
);
567 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
569 "Return the number of dimensions of the array @var{array.}\n")
570 #define FUNC_NAME s_scm_array_rank
572 return scm_from_size_t (scm_c_array_rank (array
));
577 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
579 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
580 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
582 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
584 #define FUNC_NAME s_scm_array_dimensions
586 scm_t_array_handle handle
;
591 scm_array_get_handle (ra
, &handle
);
592 s
= scm_array_handle_dims (&handle
);
593 k
= scm_array_handle_rank (&handle
);
596 res
= scm_cons (s
[k
].lbnd
597 ? scm_cons2 (scm_from_ssize_t (s
[k
].lbnd
),
598 scm_from_ssize_t (s
[k
].ubnd
),
600 : scm_from_ssize_t (1 + s
[k
].ubnd
),
603 scm_array_handle_release (&handle
);
609 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
611 "Return the root vector of a shared array.")
612 #define FUNC_NAME s_scm_shared_array_root
614 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
615 return SCM_I_ARRAY_V (ra
);
616 else if (scm_is_generalized_vector (ra
))
618 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
623 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
625 "Return the root vector index of the first element in the array.")
626 #define FUNC_NAME s_scm_shared_array_offset
628 scm_t_array_handle handle
;
631 scm_array_get_handle (ra
, &handle
);
632 res
= scm_from_size_t (handle
.base
);
633 scm_array_handle_release (&handle
);
639 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
641 "For each dimension, return the distance between elements in the root vector.")
642 #define FUNC_NAME s_scm_shared_array_increments
644 scm_t_array_handle handle
;
649 scm_array_get_handle (ra
, &handle
);
650 k
= scm_array_handle_rank (&handle
);
651 s
= scm_array_handle_dims (&handle
);
653 res
= scm_cons (scm_from_ssize_t (s
[k
].inc
), res
);
654 scm_array_handle_release (&handle
);
660 scm_array_handle_pos (scm_t_array_handle
*h
, SCM indices
)
662 scm_t_array_dim
*s
= scm_array_handle_dims (h
);
664 size_t k
= scm_array_handle_rank (h
);
666 while (k
> 0 && scm_is_pair (indices
))
668 i
= scm_to_signed_integer (SCM_CAR (indices
), s
->lbnd
, s
->ubnd
);
669 pos
+= (i
- s
->lbnd
) * s
->inc
;
672 indices
= SCM_CDR (indices
);
674 if (k
> 0 || !scm_is_null (indices
))
675 scm_misc_error (NULL
, "wrong number of indices, expecting ~a",
676 scm_list_1 (scm_from_size_t (scm_array_handle_rank (h
))));
681 scm_i_make_ra (int ndim
, int enclosed
)
683 scm_t_bits tag
= enclosed
? scm_i_tc16_enclosed_array
: scm_i_tc16_array
;
685 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
686 scm_gc_malloc ((sizeof (scm_i_t_array
) +
687 ndim
* sizeof (scm_t_array_dim
)),
689 SCM_I_ARRAY_V (ra
) = SCM_BOOL_F
;
693 static char s_bad_spec
[] = "Bad scm_array dimension";
696 /* Increments will still need to be set. */
699 scm_i_shap2ra (SCM args
)
703 int ndim
= scm_ilength (args
);
705 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
707 ra
= scm_i_make_ra (ndim
, 0);
708 SCM_I_ARRAY_BASE (ra
) = 0;
709 s
= SCM_I_ARRAY_DIMS (ra
);
710 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
712 spec
= SCM_CAR (args
);
713 if (scm_is_integer (spec
))
715 if (scm_to_long (spec
) < 0)
716 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
718 s
->ubnd
= scm_to_long (spec
) - 1;
723 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
724 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
725 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
727 if (!scm_is_pair (sp
)
728 || !scm_is_integer (SCM_CAR (sp
))
729 || !scm_is_null (SCM_CDR (sp
)))
730 scm_misc_error (NULL
, s_bad_spec
, SCM_EOL
);
731 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
738 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
739 (SCM type
, SCM fill
, SCM bounds
),
740 "Create and return an array of type @var{type}.")
741 #define FUNC_NAME s_scm_make_typed_array
745 creator_proc
*creator
;
748 creator
= type_to_creator (type
);
749 ra
= scm_i_shap2ra (bounds
);
750 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
751 s
= SCM_I_ARRAY_DIMS (ra
);
752 k
= SCM_I_ARRAY_NDIM (ra
);
757 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
+ 1);
758 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
761 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
762 fill
= SCM_UNDEFINED
;
764 SCM_I_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
766 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
767 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
768 return SCM_I_ARRAY_V (ra
);
773 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
774 (SCM fill
, SCM bounds
),
775 "Create and return an array.")
776 #define FUNC_NAME s_scm_make_array
778 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
782 #if SCM_ENABLE_DEPRECATED
784 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
785 (SCM dims
, SCM prot
, SCM fill
),
786 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
787 "Create and return a uniform array or vector of type\n"
788 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
789 "length @var{length}. If @var{fill} is supplied, it's used to\n"
790 "fill the array, otherwise @var{prototype} is used.")
791 #define FUNC_NAME s_scm_dimensions_to_uniform_array
793 scm_c_issue_deprecation_warning
794 ("`dimensions->uniform-array' is deprecated. "
795 "Use `make-typed-array' instead.");
797 if (scm_is_integer (dims
))
798 dims
= scm_list_1 (dims
);
800 if (SCM_UNBNDP (fill
))
802 /* Using #\nul as the prototype yields a s8 array, but numeric
803 arrays can't store characters, so we have to special case this.
805 if (scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
806 fill
= scm_from_int (0);
811 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
818 scm_i_ra_set_contp (SCM ra
)
820 size_t k
= SCM_I_ARRAY_NDIM (ra
);
823 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
826 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
828 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
831 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
832 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
835 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
839 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
840 (SCM oldra
, SCM mapfunc
, SCM dims
),
841 "@code{make-shared-array} can be used to create shared subarrays of other\n"
842 "arrays. The @var{mapper} is a function that translates coordinates in\n"
843 "the new array into coordinates in the old array. A @var{mapper} must be\n"
844 "linear, and its range must stay within the bounds of the old array, but\n"
845 "it can be otherwise arbitrary. A simple example:\n"
847 "(define fred (make-array #f 8 8))\n"
848 "(define freds-diagonal\n"
849 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
850 "(array-set! freds-diagonal 'foo 3)\n"
851 "(array-ref fred 3 3) @result{} foo\n"
852 "(define freds-center\n"
853 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
854 "(array-ref freds-center 0 0) @result{} foo\n"
856 #define FUNC_NAME s_scm_make_shared_array
858 scm_t_array_handle old_handle
;
864 long old_base
, old_min
, new_min
, old_max
, new_max
;
867 SCM_VALIDATE_REST_ARGUMENT (dims
);
868 SCM_VALIDATE_PROC (2, mapfunc
);
869 ra
= scm_i_shap2ra (dims
);
871 scm_array_get_handle (oldra
, &old_handle
);
873 if (SCM_I_ARRAYP (oldra
))
875 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
876 old_base
= old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
877 s
= scm_array_handle_dims (&old_handle
);
878 k
= scm_array_handle_rank (&old_handle
);
882 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
884 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
889 SCM_I_ARRAY_V (ra
) = oldra
;
890 old_base
= old_min
= 0;
891 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
895 s
= SCM_I_ARRAY_DIMS (ra
);
896 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
898 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
899 if (s
[k
].ubnd
< s
[k
].lbnd
)
901 if (1 == SCM_I_ARRAY_NDIM (ra
))
902 ra
= make_typed_vector (scm_array_type (ra
), 0);
904 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
905 scm_array_handle_release (&old_handle
);
910 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
911 i
= scm_array_handle_pos (&old_handle
, imap
);
912 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ old_base
;
914 k
= SCM_I_ARRAY_NDIM (ra
);
917 if (s
[k
].ubnd
> s
[k
].lbnd
)
919 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
920 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
921 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
924 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
926 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
929 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
930 indptr
= SCM_CDR (indptr
);
933 scm_array_handle_release (&old_handle
);
935 if (old_min
> new_min
|| old_max
< new_max
)
936 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
937 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
939 SCM v
= SCM_I_ARRAY_V (ra
);
940 size_t length
= scm_c_generalized_vector_length (v
);
941 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
943 if (s
->ubnd
< s
->lbnd
)
944 return make_typed_vector (scm_array_type (ra
), 0);
946 scm_i_ra_set_contp (ra
);
952 /* args are RA . DIMS */
953 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
955 "Return an array sharing contents with @var{array}, but with\n"
956 "dimensions arranged in a different order. There must be one\n"
957 "@var{dim} argument for each dimension of @var{array}.\n"
958 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
959 "and the rank of the array to be returned. Each integer in that\n"
960 "range must appear at least once in the argument list.\n"
962 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
963 "dimensions in the array to be returned, their positions in the\n"
964 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
965 "may have the same value, in which case the returned array will\n"
966 "have smaller rank than @var{array}.\n"
969 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
970 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
971 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
972 " #2((a 4) (b 5) (c 6))\n"
974 #define FUNC_NAME s_scm_transpose_array
977 scm_t_array_dim
*s
, *r
;
980 SCM_VALIDATE_REST_ARGUMENT (args
);
981 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
983 if (scm_is_generalized_vector (ra
))
985 /* Make sure that we are called with a single zero as
988 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
989 SCM_WRONG_NUM_ARGS ();
990 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
991 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
995 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
997 vargs
= scm_vector (args
);
998 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
999 SCM_WRONG_NUM_ARGS ();
1001 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
1003 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
1004 0, SCM_I_ARRAY_NDIM(ra
));
1009 res
= scm_i_make_ra (ndim
, 0);
1010 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
1011 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
1012 for (k
= ndim
; k
--;)
1014 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
1015 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
1017 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1019 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
1020 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
1021 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
1022 if (r
->ubnd
< r
->lbnd
)
1031 if (r
->ubnd
> s
->ubnd
)
1033 if (r
->lbnd
< s
->lbnd
)
1035 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1042 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1043 scm_i_ra_set_contp (res
);
1047 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1051 /* args are RA . AXES */
1052 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1054 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1055 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1056 "resembling an array of shared arrays. The dimensions of each shared\n"
1057 "array are the same as the @var{dim}th dimensions of the original array,\n"
1058 "the dimensions of the outer array are the same as those of the original\n"
1059 "array that did not match a @var{dim}.\n\n"
1060 "An enclosed array is not a general Scheme array. Its elements may not\n"
1061 "be set using @code{array-set!}. Two references to the same element of\n"
1062 "an enclosed array will be @code{equal?} but will not in general be\n"
1063 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1064 "enclosed array is unspecified.\n\n"
1067 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1068 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1069 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1070 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1072 #define FUNC_NAME s_scm_enclose_array
1074 SCM axv
, res
, ra_inr
;
1076 scm_t_array_dim vdim
, *s
= &vdim
;
1077 int ndim
, j
, k
, ninr
, noutr
;
1079 SCM_VALIDATE_REST_ARGUMENT (axes
);
1080 if (scm_is_null (axes
))
1081 axes
= scm_cons ((SCM_I_ARRAYP (ra
) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1082 ninr
= scm_ilength (axes
);
1084 SCM_WRONG_NUM_ARGS ();
1085 ra_inr
= scm_i_make_ra (ninr
, 0);
1087 if (scm_is_generalized_vector (ra
))
1090 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1092 SCM_I_ARRAY_V (ra_inr
) = ra
;
1093 SCM_I_ARRAY_BASE (ra_inr
) = 0;
1096 else if (SCM_I_ARRAYP (ra
))
1098 s
= SCM_I_ARRAY_DIMS (ra
);
1099 SCM_I_ARRAY_V (ra_inr
) = SCM_I_ARRAY_V (ra
);
1100 SCM_I_ARRAY_BASE (ra_inr
) = SCM_I_ARRAY_BASE (ra
);
1101 ndim
= SCM_I_ARRAY_NDIM (ra
);
1104 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1106 noutr
= ndim
- ninr
;
1108 SCM_WRONG_NUM_ARGS ();
1109 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1110 res
= scm_i_make_ra (noutr
, 1);
1111 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra_inr
);
1112 SCM_I_ARRAY_V (res
) = ra_inr
;
1113 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1115 if (!scm_is_integer (SCM_CAR (axes
)))
1116 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1117 j
= scm_to_int (SCM_CAR (axes
));
1118 SCM_I_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1119 SCM_I_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1120 SCM_I_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1121 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1123 c_axv
= scm_i_string_chars (axv
);
1124 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1128 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1129 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1130 SCM_I_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1132 scm_remember_upto_here_1 (axv
);
1133 scm_i_ra_set_contp (ra_inr
);
1134 scm_i_ra_set_contp (res
);
1141 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1143 "Return @code{#t} if its arguments would be acceptable to\n"
1144 "@code{array-ref}.")
1145 #define FUNC_NAME s_scm_array_in_bounds_p
1147 SCM res
= SCM_BOOL_T
;
1149 SCM_VALIDATE_REST_ARGUMENT (args
);
1151 if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
1153 size_t k
= 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))
1475 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1477 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1478 size_t word_len
= (bit_len
+31)/32;
1479 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1482 scm_puts ("#*", port
);
1483 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1485 scm_t_uint32 mask
= 1;
1486 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1487 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1494 bitvector_equalp (SCM vec1
, SCM vec2
)
1496 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1497 size_t word_len
= (bit_len
+ 31) / 32;
1498 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1499 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1500 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1502 /* compare lengths */
1503 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1505 /* avoid underflow in word_len-1 below. */
1508 /* compare full words */
1509 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1511 /* compare partial last words */
1512 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1518 scm_is_bitvector (SCM vec
)
1520 return IS_BITVECTOR (vec
);
1523 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1525 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1526 "return @code{#f}.")
1527 #define FUNC_NAME s_scm_bitvector_p
1529 return scm_from_bool (scm_is_bitvector (obj
));
1534 scm_c_make_bitvector (size_t len
, SCM fill
)
1536 size_t word_len
= (len
+ 31) / 32;
1540 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1542 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1544 if (!SCM_UNBNDP (fill
))
1545 scm_bitvector_fill_x (res
, fill
);
1550 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1551 (SCM len
, SCM fill
),
1552 "Create a new bitvector of length @var{len} and\n"
1553 "optionally initialize all elements to @var{fill}.")
1554 #define FUNC_NAME s_scm_make_bitvector
1556 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1560 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1562 "Create a new bitvector with the arguments as elements.")
1563 #define FUNC_NAME s_scm_bitvector
1565 return scm_list_to_bitvector (bits
);
1570 scm_c_bitvector_length (SCM vec
)
1572 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1573 return BITVECTOR_LENGTH (vec
);
1576 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1578 "Return the length of the bitvector @var{vec}.")
1579 #define FUNC_NAME s_scm_bitvector_length
1581 return scm_from_size_t (scm_c_bitvector_length (vec
));
1585 const scm_t_uint32
*
1586 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1588 return scm_array_handle_bit_writable_elements (h
);
1592 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1595 if (SCM_I_ARRAYP (vec
))
1596 vec
= SCM_I_ARRAY_V (vec
);
1597 if (IS_BITVECTOR (vec
))
1598 return BITVECTOR_BITS (vec
) + h
->base
/32;
1599 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1603 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1605 return h
->base
% 32;
1608 const scm_t_uint32
*
1609 scm_bitvector_elements (SCM vec
,
1610 scm_t_array_handle
*h
,
1615 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1620 scm_bitvector_writable_elements (SCM vec
,
1621 scm_t_array_handle
*h
,
1626 scm_generalized_vector_get_handle (vec
, h
);
1629 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1630 *offp
= scm_array_handle_bit_elements_offset (h
);
1631 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1634 return scm_array_handle_bit_writable_elements (h
);
1638 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1640 scm_t_array_handle handle
;
1641 const scm_t_uint32
*bits
;
1643 if (IS_BITVECTOR (vec
))
1645 if (idx
>= BITVECTOR_LENGTH (vec
))
1646 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1647 bits
= BITVECTOR_BITS(vec
);
1648 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1656 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1658 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1659 idx
= idx
*inc
+ off
;
1660 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1661 scm_array_handle_release (&handle
);
1666 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1668 "Return the element at index @var{idx} of the bitvector\n"
1670 #define FUNC_NAME s_scm_bitvector_ref
1672 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1677 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1679 scm_t_array_handle handle
;
1680 scm_t_uint32
*bits
, mask
;
1682 if (IS_BITVECTOR (vec
))
1684 if (idx
>= BITVECTOR_LENGTH (vec
))
1685 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1686 bits
= BITVECTOR_BITS(vec
);
1693 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1695 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1696 idx
= idx
*inc
+ off
;
1699 mask
= 1L << (idx
%32);
1700 if (scm_is_true (val
))
1701 bits
[idx
/32] |= mask
;
1703 bits
[idx
/32] &= ~mask
;
1705 if (!IS_BITVECTOR (vec
))
1706 scm_array_handle_release (&handle
);
1709 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1710 (SCM vec
, SCM idx
, SCM val
),
1711 "Set the element at index @var{idx} of the bitvector\n"
1712 "@var{vec} when @var{val} is true, else clear it.")
1713 #define FUNC_NAME s_scm_bitvector_set_x
1715 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1716 return SCM_UNSPECIFIED
;
1720 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1722 "Set all elements of the bitvector\n"
1723 "@var{vec} when @var{val} is true, else clear them.")
1724 #define FUNC_NAME s_scm_bitvector_fill_x
1726 scm_t_array_handle handle
;
1731 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1734 if (off
== 0 && inc
== 1 && len
> 0)
1738 size_t word_len
= (len
+ 31) / 32;
1739 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1741 if (scm_is_true (val
))
1743 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1744 bits
[word_len
-1] |= last_mask
;
1748 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1749 bits
[word_len
-1] &= ~last_mask
;
1755 for (i
= 0; i
< len
; i
++)
1756 scm_array_handle_set (&handle
, i
*inc
, val
);
1759 scm_array_handle_release (&handle
);
1761 return SCM_UNSPECIFIED
;
1765 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1767 "Return a new bitvector initialized with the elements\n"
1769 #define FUNC_NAME s_scm_list_to_bitvector
1771 size_t bit_len
= scm_to_size_t (scm_length (list
));
1772 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1773 size_t word_len
= (bit_len
+31)/32;
1774 scm_t_array_handle handle
;
1775 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1779 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1781 scm_t_uint32 mask
= 1;
1783 for (j
= 0; j
< 32 && j
< bit_len
;
1784 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1785 if (scm_is_true (SCM_CAR (list
)))
1789 scm_array_handle_release (&handle
);
1795 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1797 "Return a new list initialized with the elements\n"
1798 "of the bitvector @var{vec}.")
1799 #define FUNC_NAME s_scm_bitvector_to_list
1801 scm_t_array_handle handle
;
1807 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1810 if (off
== 0 && inc
== 1)
1814 size_t word_len
= (len
+ 31) / 32;
1817 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1819 scm_t_uint32 mask
= 1;
1820 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1821 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1827 for (i
= 0; i
< len
; i
++)
1828 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1831 scm_array_handle_release (&handle
);
1833 return scm_reverse_x (res
, SCM_EOL
);
1837 /* From mmix-arith.w by Knuth.
1839 Here's a fun way to count the number of bits in a tetrabyte.
1841 [This classical trick is called the ``Gillies--Miller method for
1842 sideways addition'' in {\sl The Preparation of Programs for an
1843 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1844 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1845 the tricks used here were suggested by Balbir Singh, Peter
1846 Rossmanith, and Stefan Schwoon.]
1850 count_ones (scm_t_uint32 x
)
1852 x
=x
-((x
>>1)&0x55555555);
1853 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1854 x
=(x
+(x
>>4))&0x0f0f0f0f;
1856 return (x
+(x
>>16)) & 0xff;
1859 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1860 (SCM b
, SCM bitvector
),
1861 "Return the number of occurrences of the boolean @var{b} in\n"
1863 #define FUNC_NAME s_scm_bit_count
1865 scm_t_array_handle handle
;
1869 int bit
= scm_to_bool (b
);
1872 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1875 if (off
== 0 && inc
== 1 && len
> 0)
1879 size_t word_len
= (len
+ 31) / 32;
1880 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1883 for (i
= 0; i
< word_len
-1; i
++)
1884 count
+= count_ones (bits
[i
]);
1885 count
+= count_ones (bits
[i
] & last_mask
);
1890 for (i
= 0; i
< len
; i
++)
1891 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1895 scm_array_handle_release (&handle
);
1897 return scm_from_size_t (bit
? count
: len
-count
);
1901 /* returns 32 for x == 0.
1904 find_first_one (scm_t_uint32 x
)
1907 /* do a binary search in x. */
1908 if ((x
& 0xFFFF) == 0)
1909 x
>>= 16, pos
+= 16;
1910 if ((x
& 0xFF) == 0)
1921 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1922 (SCM item
, SCM v
, SCM k
),
1923 "Return the index of the first occurrance of @var{item} in bit\n"
1924 "vector @var{v}, starting from @var{k}. If there is no\n"
1925 "@var{item} entry between @var{k} and the end of\n"
1926 "@var{bitvector}, then return @code{#f}. For example,\n"
1929 "(bit-position #t #*000101 0) @result{} 3\n"
1930 "(bit-position #f #*0001111 3) @result{} #f\n"
1932 #define FUNC_NAME s_scm_bit_position
1934 scm_t_array_handle handle
;
1935 size_t off
, len
, first_bit
;
1937 const scm_t_uint32
*bits
;
1938 int bit
= scm_to_bool (item
);
1939 SCM res
= SCM_BOOL_F
;
1941 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1942 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1944 if (off
== 0 && inc
== 1 && len
> 0)
1946 size_t i
, word_len
= (len
+ 31) / 32;
1947 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1948 size_t first_word
= first_bit
/ 32;
1949 scm_t_uint32 first_mask
=
1950 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1953 for (i
= first_word
; i
< word_len
; i
++)
1955 w
= (bit
? bits
[i
] : ~bits
[i
]);
1956 if (i
== first_word
)
1958 if (i
== word_len
-1)
1962 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1970 for (i
= first_bit
; i
< len
; i
++)
1972 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1973 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1975 res
= scm_from_size_t (i
);
1981 scm_array_handle_release (&handle
);
1987 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1988 (SCM v
, SCM kv
, SCM obj
),
1989 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1990 "selecting the entries to change. The return value is\n"
1993 "If @var{kv} is a bit vector, then those entries where it has\n"
1994 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1995 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1996 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1997 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
2000 "(define bv #*01000010)\n"
2001 "(bit-set*! bv #*10010001 #t)\n"
2003 "@result{} #*11010011\n"
2006 "If @var{kv} is a u32vector, then its elements are\n"
2007 "indices into @var{v} which are set to @var{obj}.\n"
2010 "(define bv #*01000010)\n"
2011 "(bit-set*! bv #u32(5 2 7) #t)\n"
2013 "@result{} #*01100111\n"
2015 #define FUNC_NAME s_scm_bit_set_star_x
2017 scm_t_array_handle v_handle
;
2018 size_t v_off
, v_len
;
2020 scm_t_uint32
*v_bits
;
2023 /* Validate that OBJ is a boolean so this is done even if we don't
2026 bit
= scm_to_bool (obj
);
2028 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2029 &v_off
, &v_len
, &v_inc
);
2031 if (scm_is_bitvector (kv
))
2033 scm_t_array_handle kv_handle
;
2034 size_t kv_off
, kv_len
;
2036 const scm_t_uint32
*kv_bits
;
2038 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2039 &kv_off
, &kv_len
, &kv_inc
);
2041 if (v_len
!= kv_len
)
2042 scm_misc_error (NULL
,
2043 "bit vectors must have equal length",
2046 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2048 size_t word_len
= (kv_len
+ 31) / 32;
2049 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2054 for (i
= 0; i
< word_len
-1; i
++)
2055 v_bits
[i
] &= ~kv_bits
[i
];
2056 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2060 for (i
= 0; i
< word_len
-1; i
++)
2061 v_bits
[i
] |= kv_bits
[i
];
2062 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2068 for (i
= 0; i
< kv_len
; i
++)
2069 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2070 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2073 scm_array_handle_release (&kv_handle
);
2076 else if (scm_is_true (scm_u32vector_p (kv
)))
2078 scm_t_array_handle kv_handle
;
2081 const scm_t_uint32
*kv_elts
;
2083 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2084 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2085 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2087 scm_array_handle_release (&kv_handle
);
2090 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2092 scm_array_handle_release (&v_handle
);
2094 return SCM_UNSPECIFIED
;
2099 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2100 (SCM v
, SCM kv
, SCM obj
),
2101 "Return a count of how many entries in bit vector @var{v} are\n"
2102 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2105 "If @var{kv} is a bit vector, then those entries where it has\n"
2106 "@code{#t} are the ones in @var{v} which are considered.\n"
2107 "@var{kv} and @var{v} must be the same length.\n"
2109 "If @var{kv} is a u32vector, then it contains\n"
2110 "the indexes in @var{v} to consider.\n"
2115 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2116 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2118 #define FUNC_NAME s_scm_bit_count_star
2120 scm_t_array_handle v_handle
;
2121 size_t v_off
, v_len
;
2123 const scm_t_uint32
*v_bits
;
2127 /* Validate that OBJ is a boolean so this is done even if we don't
2130 bit
= scm_to_bool (obj
);
2132 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2133 &v_off
, &v_len
, &v_inc
);
2135 if (scm_is_bitvector (kv
))
2137 scm_t_array_handle kv_handle
;
2138 size_t kv_off
, kv_len
;
2140 const scm_t_uint32
*kv_bits
;
2142 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2143 &kv_off
, &kv_len
, &kv_inc
);
2145 if (v_len
!= kv_len
)
2146 scm_misc_error (NULL
,
2147 "bit vectors must have equal length",
2150 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2152 size_t i
, word_len
= (kv_len
+ 31) / 32;
2153 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2154 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2156 for (i
= 0; i
< word_len
-1; i
++)
2157 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2158 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2163 for (i
= 0; i
< kv_len
; i
++)
2164 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2166 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2167 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2172 scm_array_handle_release (&kv_handle
);
2175 else if (scm_is_true (scm_u32vector_p (kv
)))
2177 scm_t_array_handle kv_handle
;
2180 const scm_t_uint32
*kv_elts
;
2182 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2183 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2185 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2186 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2190 scm_array_handle_release (&kv_handle
);
2193 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2195 scm_array_handle_release (&v_handle
);
2197 return scm_from_size_t (count
);
2201 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2203 "Modify the bit vector @var{v} by replacing each element with\n"
2205 #define FUNC_NAME s_scm_bit_invert_x
2207 scm_t_array_handle handle
;
2212 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2214 if (off
== 0 && inc
== 1 && len
> 0)
2216 size_t word_len
= (len
+ 31) / 32;
2217 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2220 for (i
= 0; i
< word_len
-1; i
++)
2222 bits
[i
] = bits
[i
] ^ last_mask
;
2227 for (i
= 0; i
< len
; i
++)
2228 scm_array_handle_set (&handle
, i
*inc
,
2229 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2232 scm_array_handle_release (&handle
);
2234 return SCM_UNSPECIFIED
;
2240 scm_istr2bve (SCM str
)
2242 scm_t_array_handle handle
;
2243 size_t len
= scm_i_string_length (str
);
2244 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2252 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2253 c_str
= scm_i_string_chars (str
);
2255 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2261 for (mask
= 1L; j
--; mask
<<= 1)
2276 scm_array_handle_release (&handle
);
2277 scm_remember_upto_here_1 (str
);
2284 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2289 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2291 if (k
== SCM_I_ARRAY_NDIM (ra
))
2292 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2294 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2295 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2297 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2301 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2308 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2310 "Return a list consisting of all the elements, in order, of\n"
2312 #define FUNC_NAME s_scm_array_to_list
2314 if (scm_is_generalized_vector (v
))
2315 return scm_generalized_vector_to_list (v
);
2316 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2317 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2319 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2324 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2326 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2327 (SCM type
, SCM shape
, SCM lst
),
2328 "Return an array of the type @var{type}\n"
2329 "with elements the same as those of @var{lst}.\n"
2331 "The argument @var{shape} determines the number of dimensions\n"
2332 "of the array and their shape. It is either an exact integer,\n"
2334 "number of dimensions directly, or a list whose length\n"
2335 "specifies the number of dimensions and each element specified\n"
2336 "the lower and optionally the upper bound of the corresponding\n"
2338 "When the element is list of two elements, these elements\n"
2339 "give the lower and upper bounds. When it is an exact\n"
2340 "integer, it gives only the lower bound.")
2341 #define FUNC_NAME s_scm_list_to_typed_array
2345 scm_t_array_handle handle
;
2348 if (scm_is_integer (shape
))
2350 size_t k
= scm_to_size_t (shape
);
2354 shape
= scm_cons (scm_length (row
), shape
);
2355 if (k
> 0 && !scm_is_null (row
))
2356 row
= scm_car (row
);
2361 SCM shape_spec
= shape
;
2365 SCM spec
= scm_car (shape_spec
);
2366 if (scm_is_pair (spec
))
2367 shape
= scm_cons (spec
, shape
);
2369 shape
= scm_cons (scm_list_2 (spec
,
2370 scm_sum (scm_sum (spec
,
2372 scm_from_int (-1))),
2374 shape_spec
= scm_cdr (shape_spec
);
2375 if (scm_is_pair (shape_spec
))
2377 if (!scm_is_null (row
))
2378 row
= scm_car (row
);
2385 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2386 scm_reverse_x (shape
, SCM_EOL
));
2388 scm_array_get_handle (ra
, &handle
);
2389 l2ra (lst
, &handle
, 0, 0);
2390 scm_array_handle_release (&handle
);
2396 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2397 (SCM ndim
, SCM lst
),
2398 "Return an array with elements the same as those of @var{lst}.")
2399 #define FUNC_NAME s_scm_list_to_array
2401 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2406 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2408 if (k
== scm_array_handle_rank (handle
))
2409 scm_array_handle_set (handle
, pos
, lst
);
2412 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2413 ssize_t inc
= dim
->inc
;
2414 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2415 char *errmsg
= NULL
;
2418 while (n
> 0 && scm_is_pair (lst
))
2420 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2422 lst
= SCM_CDR (lst
);
2426 errmsg
= "too few elements for array dimension ~a, need ~a";
2427 if (!scm_is_null (lst
))
2428 errmsg
= "too many elements for array dimension ~a, want ~a";
2430 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2431 scm_from_size_t (len
)));
2435 #if SCM_ENABLE_DEPRECATED
2437 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2438 (SCM ndim
, SCM prot
, SCM lst
),
2439 "Return a uniform array of the type indicated by prototype\n"
2440 "@var{prot} with elements the same as those of @var{lst}.\n"
2441 "Elements must be of the appropriate type, no coercions are\n"
2444 "The argument @var{ndim} determines the number of dimensions\n"
2445 "of the array. It is either an exact integer, giving the\n"
2446 "number directly, or a list of exact integers, whose length\n"
2447 "specifies the number of dimensions and each element is the\n"
2448 "lower index bound of its dimension.")
2449 #define FUNC_NAME s_scm_list_to_uniform_array
2451 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2457 /* Print dimension DIM of ARRAY.
2461 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2462 SCM port
, scm_print_state
*pstate
)
2464 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2467 scm_putc ('(', port
);
2469 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2471 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2472 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2475 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2477 if (idx
< dim_spec
->ubnd
)
2478 scm_putc (' ', port
);
2479 base
+= dim_spec
->inc
;
2482 scm_putc (')', port
);
2486 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2490 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2492 long ndim
= SCM_I_ARRAY_NDIM (array
);
2493 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2494 SCM v
= SCM_I_ARRAY_V (array
);
2495 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2497 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2499 scm_putc ('#', port
);
2500 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2501 scm_intprint (ndim
, 10, port
);
2502 if (scm_is_uniform_vector (v
))
2503 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2504 else if (scm_is_bitvector (v
))
2505 scm_puts ("b", port
);
2506 else if (scm_is_string (v
))
2507 scm_puts ("a", port
);
2508 else if (!scm_is_vector (v
))
2509 scm_puts ("?", port
);
2511 for (i
= 0; i
< ndim
; i
++)
2513 if (dim_specs
[i
].lbnd
!= 0)
2515 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2521 if (print_lbnds
|| print_lens
)
2522 for (i
= 0; i
< ndim
; i
++)
2526 scm_putc ('@', port
);
2527 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2531 scm_putc (':', port
);
2532 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2539 /* Rank zero arrays, which are really just scalars, are printed
2540 specially. The consequent way would be to print them as
2544 where OBJ is the printed representation of the scalar, but we
2545 print them instead as
2549 to make them look less strange.
2551 Just printing them as
2555 would be correct in a way as well, but zero rank arrays are
2556 not really the same as Scheme values since they are boxed and
2557 can be modified with array-set!, say.
2559 scm_putc ('(', port
);
2560 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2561 scm_putc (')', port
);
2565 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2569 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2573 scm_putc ('#', port
);
2574 base
= SCM_I_ARRAY_BASE (array
);
2575 scm_puts ("<enclosed-array ", port
);
2576 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2577 scm_putc ('>', port
);
2581 /* Read an array. This function can also read vectors and uniform
2582 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2585 C is the first character read after the '#'.
2589 tag_to_type (const char *tag
, SCM port
)
2591 #if SCM_ENABLE_DEPRECATED
2593 /* Recognize the old syntax.
2595 const char *instead
;
2627 if (instead
&& tag
[1] == '\0')
2629 scm_c_issue_deprecation_warning_fmt
2630 ("The tag '%c' is deprecated for uniform vectors. "
2631 "Use '%s' instead.", tag
[0], instead
);
2632 return scm_from_locale_symbol (instead
);
2640 return scm_from_locale_symbol (tag
);
2644 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2653 c
= scm_getc (port
);
2656 while ('0' <= c
&& c
<= '9')
2658 res
= 10*res
+ c
-'0';
2660 c
= scm_getc (port
);
2669 scm_i_read_array (SCM port
, int c
)
2676 SCM shape
= SCM_BOOL_F
, elements
;
2678 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2679 the array code can not deal with zero-length dimensions yet, and
2680 we want to allow zero-length vectors, of course.
2684 scm_ungetc (c
, port
);
2685 return scm_vector (scm_read (port
));
2688 /* Disambiguate between '#f' and uniform floating point vectors.
2692 c
= scm_getc (port
);
2693 if (c
!= '3' && c
!= '6')
2696 scm_ungetc (c
, port
);
2703 goto continue_reading_tag
;
2709 c
= read_decimal_integer (port
, c
, &rank
);
2711 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2717 continue_reading_tag
:
2718 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2721 c
= scm_getc (port
);
2723 tag
[tag_len
] = '\0';
2727 if (c
== '@' || c
== ':')
2733 ssize_t lbnd
= 0, len
= 0;
2738 c
= scm_getc (port
);
2739 c
= read_decimal_integer (port
, c
, &lbnd
);
2742 s
= scm_from_ssize_t (lbnd
);
2746 c
= scm_getc (port
);
2747 c
= read_decimal_integer (port
, c
, &len
);
2748 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2751 shape
= scm_cons (s
, shape
);
2752 } while (c
== '@' || c
== ':');
2754 shape
= scm_reverse_x (shape
, SCM_EOL
);
2757 /* Read nested lists of elements.
2760 scm_i_input_error (NULL
, port
,
2761 "missing '(' in vector or array literal",
2763 scm_ungetc (c
, port
);
2764 elements
= scm_read (port
);
2766 if (scm_is_false (shape
))
2767 shape
= scm_from_ssize_t (rank
);
2768 else if (scm_ilength (shape
) != rank
)
2771 "the number of shape specifications must match the array rank",
2774 /* Handle special print syntax of rank zero arrays; see
2775 scm_i_print_array for a rationale.
2779 if (!scm_is_pair (elements
))
2780 scm_i_input_error (NULL
, port
,
2781 "too few elements in array literal, need 1",
2783 if (!scm_is_null (SCM_CDR (elements
)))
2784 scm_i_input_error (NULL
, port
,
2785 "too many elements in array literal, want 1",
2787 elements
= SCM_CAR (elements
);
2792 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2795 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2798 #define FUNC_NAME s_scm_array_type
2800 if (SCM_I_ARRAYP (ra
))
2801 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2802 else if (scm_is_generalized_vector (ra
))
2803 return scm_i_generalized_vector_type (ra
);
2804 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2805 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2807 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2811 #if SCM_ENABLE_DEPRECATED
2813 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2815 "Return an object that would produce an array of the same type\n"
2816 "as @var{array}, if used as the @var{prototype} for\n"
2817 "@code{make-uniform-array}.")
2818 #define FUNC_NAME s_scm_array_prototype
2820 if (SCM_I_ARRAYP (ra
))
2821 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2822 else if (scm_is_generalized_vector (ra
))
2823 return scm_i_get_old_prototype (ra
);
2824 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2825 return SCM_UNSPECIFIED
;
2827 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2834 #if SCM_ENABLE_DEPRECATED
2837 scm_make_ra (int ndim
)
2839 scm_c_issue_deprecation_warning
2840 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2841 return scm_i_make_ra (ndim
, 0);
2845 scm_shap2ra (SCM args
, const char *what
)
2847 scm_c_issue_deprecation_warning
2848 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2849 return scm_i_shap2ra (args
);
2853 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2855 scm_c_issue_deprecation_warning
2856 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2857 return scm_c_generalized_vector_ref (v
, pos
);
2861 scm_ra_set_contp (SCM ra
)
2863 scm_c_issue_deprecation_warning
2864 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2865 scm_i_ra_set_contp (ra
);
2869 scm_aind (SCM ra
, SCM args
, const char *what
)
2871 scm_t_array_handle handle
;
2874 scm_c_issue_deprecation_warning
2875 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2877 if (scm_is_integer (args
))
2878 args
= scm_list_1 (args
);
2880 scm_array_get_handle (ra
, &handle
);
2881 pos
= scm_array_handle_pos (&handle
, args
) + SCM_I_ARRAY_BASE (ra
);
2882 scm_array_handle_release (&handle
);
2887 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2889 scm_c_issue_deprecation_warning
2890 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2892 scm_iprin1 (exp
, port
, pstate
);
2901 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2902 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2903 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2905 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2906 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2907 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2909 scm_add_feature ("array");
2911 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2912 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2913 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2915 init_type_creator_table ();
2917 #include "libguile/unif.x"