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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_i_tc16_array
;
83 scm_t_bits scm_i_tc16_enclosed_array
;
85 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
86 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
87 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
88 (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
90 typedef SCM
creator_proc (SCM len
, SCM fill
);
95 creator_proc
*creator
;
96 } type_creator_table
[] = {
97 { "a", SCM_UNSPECIFIED
, scm_make_string
},
98 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
99 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
100 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
101 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
102 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
103 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
104 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
105 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
106 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
107 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
108 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
109 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
110 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
115 init_type_creator_table ()
118 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
120 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
121 type_creator_table
[i
].type
= scm_permanent_object (sym
);
125 static creator_proc
*
126 type_to_creator (SCM type
)
130 if (scm_is_eq (type
, SCM_BOOL_T
))
131 return scm_make_vector
;
132 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
133 if (scm_is_eq (type
, type_creator_table
[i
].type
))
134 return type_creator_table
[i
].creator
;
136 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
140 make_typed_vector (SCM type
, size_t len
)
142 creator_proc
*creator
= type_to_creator (type
);
143 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
146 #if SCM_ENABLE_DEPRECATED
148 SCM_SYMBOL (scm_sym_s
, "s");
149 SCM_SYMBOL (scm_sym_l
, "l");
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
);
799 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
806 scm_i_ra_set_contp (SCM ra
)
808 size_t k
= SCM_I_ARRAY_NDIM (ra
);
811 long inc
= SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
;
814 if (inc
!= SCM_I_ARRAY_DIMS (ra
)[k
].inc
)
816 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
819 inc
*= (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
820 - SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
823 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
827 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
828 (SCM oldra
, SCM mapfunc
, SCM dims
),
829 "@code{make-shared-array} can be used to create shared subarrays of other\n"
830 "arrays. The @var{mapper} is a function that translates coordinates in\n"
831 "the new array into coordinates in the old array. A @var{mapper} must be\n"
832 "linear, and its range must stay within the bounds of the old array, but\n"
833 "it can be otherwise arbitrary. A simple example:\n"
835 "(define fred (make-array #f 8 8))\n"
836 "(define freds-diagonal\n"
837 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
838 "(array-set! freds-diagonal 'foo 3)\n"
839 "(array-ref fred 3 3) @result{} foo\n"
840 "(define freds-center\n"
841 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
842 "(array-ref freds-center 0 0) @result{} foo\n"
844 #define FUNC_NAME s_scm_make_shared_array
846 scm_t_array_handle old_handle
;
852 long old_min
, new_min
, old_max
, new_max
;
855 SCM_VALIDATE_REST_ARGUMENT (dims
);
856 SCM_VALIDATE_PROC (2, mapfunc
);
857 ra
= scm_i_shap2ra (dims
);
859 scm_array_get_handle (oldra
, &old_handle
);
861 if (SCM_I_ARRAYP (oldra
))
863 SCM_I_ARRAY_V (ra
) = SCM_I_ARRAY_V (oldra
);
864 old_min
= old_max
= SCM_I_ARRAY_BASE (oldra
);
865 s
= scm_array_handle_dims (&old_handle
);
866 k
= scm_array_handle_rank (&old_handle
);
870 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
872 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
877 SCM_I_ARRAY_V (ra
) = oldra
;
879 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
883 s
= SCM_I_ARRAY_DIMS (ra
);
884 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
886 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
887 if (s
[k
].ubnd
< s
[k
].lbnd
)
889 if (1 == SCM_I_ARRAY_NDIM (ra
))
890 ra
= make_typed_vector (scm_array_type (ra
), 0);
892 SCM_I_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
893 scm_array_handle_release (&old_handle
);
898 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
899 i
= scm_array_handle_pos (&old_handle
, imap
);
900 SCM_I_ARRAY_BASE (ra
) = new_min
= new_max
= i
+ SCM_I_ARRAY_BASE (oldra
);
902 k
= SCM_I_ARRAY_NDIM (ra
);
905 if (s
[k
].ubnd
> s
[k
].lbnd
)
907 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
908 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
909 s
[k
].inc
= scm_array_handle_pos (&old_handle
, imap
) - i
;
912 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
914 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
917 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
918 indptr
= SCM_CDR (indptr
);
921 scm_array_handle_release (&old_handle
);
923 if (old_min
> new_min
|| old_max
< new_max
)
924 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
925 if (1 == SCM_I_ARRAY_NDIM (ra
) && 0 == SCM_I_ARRAY_BASE (ra
))
927 SCM v
= SCM_I_ARRAY_V (ra
);
928 size_t length
= scm_c_generalized_vector_length (v
);
929 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
931 if (s
->ubnd
< s
->lbnd
)
932 return make_typed_vector (scm_array_type (ra
), 0);
934 scm_i_ra_set_contp (ra
);
940 /* args are RA . DIMS */
941 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
943 "Return an array sharing contents with @var{array}, but with\n"
944 "dimensions arranged in a different order. There must be one\n"
945 "@var{dim} argument for each dimension of @var{array}.\n"
946 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
947 "and the rank of the array to be returned. Each integer in that\n"
948 "range must appear at least once in the argument list.\n"
950 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
951 "dimensions in the array to be returned, their positions in the\n"
952 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
953 "may have the same value, in which case the returned array will\n"
954 "have smaller rank than @var{array}.\n"
957 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
958 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
959 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
960 " #2((a 4) (b 5) (c 6))\n"
962 #define FUNC_NAME s_scm_transpose_array
965 scm_t_array_dim
*s
, *r
;
968 SCM_VALIDATE_REST_ARGUMENT (args
);
969 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
971 if (scm_is_generalized_vector (ra
))
973 /* Make sure that we are called with a single zero as
976 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
977 SCM_WRONG_NUM_ARGS ();
978 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
979 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
983 if (SCM_I_ARRAYP (ra
) || SCM_I_ENCLOSED_ARRAYP (ra
))
985 vargs
= scm_vector (args
);
986 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_I_ARRAY_NDIM (ra
))
987 SCM_WRONG_NUM_ARGS ();
989 for (k
= 0; k
< SCM_I_ARRAY_NDIM (ra
); k
++)
991 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
992 0, SCM_I_ARRAY_NDIM(ra
));
997 res
= scm_i_make_ra (ndim
, 0);
998 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (ra
);
999 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra
);
1000 for (k
= ndim
; k
--;)
1002 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= 0;
1003 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= -1;
1005 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1007 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
1008 s
= &(SCM_I_ARRAY_DIMS (ra
)[k
]);
1009 r
= &(SCM_I_ARRAY_DIMS (res
)[i
]);
1010 if (r
->ubnd
< r
->lbnd
)
1019 if (r
->ubnd
> s
->ubnd
)
1021 if (r
->lbnd
< s
->lbnd
)
1023 SCM_I_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
1030 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
1031 scm_i_ra_set_contp (res
);
1035 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1039 /* args are RA . AXES */
1040 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
1042 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
1043 "the rank of @var{array}. @var{enclose-array} returns an array\n"
1044 "resembling an array of shared arrays. The dimensions of each shared\n"
1045 "array are the same as the @var{dim}th dimensions of the original array,\n"
1046 "the dimensions of the outer array are the same as those of the original\n"
1047 "array that did not match a @var{dim}.\n\n"
1048 "An enclosed array is not a general Scheme array. Its elements may not\n"
1049 "be set using @code{array-set!}. Two references to the same element of\n"
1050 "an enclosed array will be @code{equal?} but will not in general be\n"
1051 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
1052 "enclosed array is unspecified.\n\n"
1055 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
1056 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
1057 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
1058 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
1060 #define FUNC_NAME s_scm_enclose_array
1062 SCM axv
, res
, ra_inr
;
1064 scm_t_array_dim vdim
, *s
= &vdim
;
1065 int ndim
, j
, k
, ninr
, noutr
;
1067 SCM_VALIDATE_REST_ARGUMENT (axes
);
1068 if (scm_is_null (axes
))
1069 axes
= scm_cons ((SCM_I_ARRAYP (ra
) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
1070 ninr
= scm_ilength (axes
);
1072 SCM_WRONG_NUM_ARGS ();
1073 ra_inr
= scm_i_make_ra (ninr
, 0);
1075 if (scm_is_generalized_vector (ra
))
1078 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
1080 SCM_I_ARRAY_V (ra_inr
) = ra
;
1081 SCM_I_ARRAY_BASE (ra_inr
) = 0;
1084 else if (SCM_I_ARRAYP (ra
))
1086 s
= SCM_I_ARRAY_DIMS (ra
);
1087 SCM_I_ARRAY_V (ra_inr
) = SCM_I_ARRAY_V (ra
);
1088 SCM_I_ARRAY_BASE (ra_inr
) = SCM_I_ARRAY_BASE (ra
);
1089 ndim
= SCM_I_ARRAY_NDIM (ra
);
1092 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1094 noutr
= ndim
- ninr
;
1096 SCM_WRONG_NUM_ARGS ();
1097 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1098 res
= scm_i_make_ra (noutr
, 1);
1099 SCM_I_ARRAY_BASE (res
) = SCM_I_ARRAY_BASE (ra_inr
);
1100 SCM_I_ARRAY_V (res
) = ra_inr
;
1101 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1103 if (!scm_is_integer (SCM_CAR (axes
)))
1104 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1105 j
= scm_to_int (SCM_CAR (axes
));
1106 SCM_I_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1107 SCM_I_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1108 SCM_I_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1109 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1111 c_axv
= scm_i_string_chars (axv
);
1112 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1116 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1117 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1118 SCM_I_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1120 scm_remember_upto_here_1 (axv
);
1121 scm_i_ra_set_contp (ra_inr
);
1122 scm_i_ra_set_contp (res
);
1129 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1131 "Return @code{#t} if its arguments would be acceptable to\n"
1132 "@code{array-ref}.")
1133 #define FUNC_NAME s_scm_array_in_bounds_p
1135 SCM res
= SCM_BOOL_T
;
1137 SCM_VALIDATE_REST_ARGUMENT (args
);
1139 if (scm_is_generalized_vector (v
))
1143 if (!scm_is_pair (args
))
1144 SCM_WRONG_NUM_ARGS ();
1145 ind
= scm_to_long (SCM_CAR (args
));
1146 args
= SCM_CDR (args
);
1147 res
= scm_from_bool (ind
>= 0
1148 && ind
< scm_c_generalized_vector_length (v
));
1150 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
1152 size_t k
= SCM_I_ARRAY_NDIM (v
);
1153 scm_t_array_dim
*s
= SCM_I_ARRAY_DIMS (v
);
1159 if (!scm_is_pair (args
))
1160 SCM_WRONG_NUM_ARGS ();
1161 ind
= scm_to_long (SCM_CAR (args
));
1162 args
= SCM_CDR (args
);
1165 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1168 /* We do not stop the checking after finding a violation
1169 since we want to validate the type-correctness and
1170 number of arguments in any case.
1176 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1178 if (!scm_is_null (args
))
1179 SCM_WRONG_NUM_ARGS ();
1186 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1190 int k
= SCM_I_ARRAY_NDIM (v
);
1191 SCM res
= scm_i_make_ra (k
, 0);
1192 SCM_I_ARRAY_V (res
) = SCM_I_ARRAY_V (v
);
1193 SCM_I_ARRAY_BASE (res
) = pos
;
1196 SCM_I_ARRAY_DIMS (res
)[k
].ubnd
= SCM_I_ARRAY_DIMS (v
)[k
].ubnd
;
1197 SCM_I_ARRAY_DIMS (res
)[k
].lbnd
= SCM_I_ARRAY_DIMS (v
)[k
].lbnd
;
1198 SCM_I_ARRAY_DIMS (res
)[k
].inc
= SCM_I_ARRAY_DIMS (v
)[k
].inc
;
1203 return scm_c_generalized_vector_ref (v
, pos
);
1206 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1208 "Return the element at the @code{(index1, index2)} element in\n"
1210 #define FUNC_NAME s_scm_array_ref
1212 scm_t_array_handle handle
;
1215 scm_array_get_handle (v
, &handle
);
1216 res
= scm_array_handle_ref (&handle
, scm_array_handle_pos (&handle
, args
));
1217 scm_array_handle_release (&handle
);
1223 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1224 (SCM v
, SCM obj
, SCM args
),
1225 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1226 "@var{new-value}. The value returned by array-set! is unspecified.")
1227 #define FUNC_NAME s_scm_array_set_x
1229 scm_t_array_handle handle
;
1231 scm_array_get_handle (v
, &handle
);
1232 scm_array_handle_set (&handle
, scm_array_handle_pos (&handle
, args
), obj
);
1233 scm_array_handle_release (&handle
);
1234 return SCM_UNSPECIFIED
;
1238 /* attempts to unroll an array into a one-dimensional array.
1239 returns the unrolled array or #f if it can't be done. */
1240 /* if strict is not SCM_UNDEFINED, return #f if returned array
1241 wouldn't have contiguous elements. */
1242 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1243 (SCM ra
, SCM strict
),
1244 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1245 "without changing their order (last subscript changing fastest), then\n"
1246 "@code{array-contents} returns that shared array, otherwise it returns\n"
1247 "@code{#f}. All arrays made by @var{make-array} and\n"
1248 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1249 "@var{make-shared-array} may not be.\n\n"
1250 "If the optional argument @var{strict} is provided, a shared array will\n"
1251 "be returned only if its elements are stored internally contiguous in\n"
1253 #define FUNC_NAME s_scm_array_contents
1257 if (scm_is_generalized_vector (ra
))
1260 if (SCM_I_ARRAYP (ra
))
1262 size_t k
, ndim
= SCM_I_ARRAY_NDIM (ra
), len
= 1;
1263 if (!SCM_I_ARRAYP (ra
) || !SCM_I_ARRAY_CONTP (ra
))
1265 for (k
= 0; k
< ndim
; k
++)
1266 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1267 if (!SCM_UNBNDP (strict
))
1269 if (ndim
&& (1 != SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1271 if (scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1273 if (len
!= scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) ||
1274 SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1281 SCM v
= SCM_I_ARRAY_V (ra
);
1282 size_t length
= scm_c_generalized_vector_length (v
);
1283 if ((len
== length
) && 0 == SCM_I_ARRAY_BASE (ra
) && SCM_I_ARRAY_DIMS (ra
)->inc
)
1287 sra
= scm_i_make_ra (1, 0);
1288 SCM_I_ARRAY_DIMS (sra
)->lbnd
= 0;
1289 SCM_I_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1290 SCM_I_ARRAY_V (sra
) = SCM_I_ARRAY_V (ra
);
1291 SCM_I_ARRAY_BASE (sra
) = SCM_I_ARRAY_BASE (ra
);
1292 SCM_I_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_I_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1295 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
1296 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1298 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1304 scm_ra2contig (SCM ra
, int copy
)
1309 for (k
= SCM_I_ARRAY_NDIM (ra
); k
--;)
1310 len
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1311 k
= SCM_I_ARRAY_NDIM (ra
);
1312 if (SCM_I_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_I_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1314 if (!scm_is_bitvector (SCM_I_ARRAY_V (ra
)))
1316 if ((len
== scm_c_bitvector_length (SCM_I_ARRAY_V (ra
)) &&
1317 0 == SCM_I_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1318 0 == len
% SCM_LONG_BIT
))
1321 ret
= scm_i_make_ra (k
, 0);
1322 SCM_I_ARRAY_BASE (ret
) = 0;
1325 SCM_I_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
;
1326 SCM_I_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
;
1327 SCM_I_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1328 inc
*= SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1330 SCM_I_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1332 scm_array_copy_x (ra
, ret
);
1338 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1339 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1340 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1341 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1342 "binary objects from @var{port-or-fdes}.\n"
1343 "If an end of file is encountered,\n"
1344 "the objects up to that point are put into @var{ura}\n"
1345 "(starting at the beginning) and the remainder of the array is\n"
1347 "The optional arguments @var{start} and @var{end} allow\n"
1348 "a specified region of a vector (or linearized array) to be read,\n"
1349 "leaving the remainder of the vector unchanged.\n\n"
1350 "@code{uniform-array-read!} returns the number of objects read.\n"
1351 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1352 "returned by @code{(current-input-port)}.")
1353 #define FUNC_NAME s_scm_uniform_array_read_x
1355 if (SCM_UNBNDP (port_or_fd
))
1356 port_or_fd
= scm_current_input_port ();
1358 if (scm_is_uniform_vector (ura
))
1360 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1362 else if (SCM_I_ARRAYP (ura
))
1364 size_t base
, vlen
, cstart
, cend
;
1367 cra
= scm_ra2contig (ura
, 0);
1368 base
= SCM_I_ARRAY_BASE (cra
);
1369 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1370 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1374 if (!SCM_UNBNDP (start
))
1376 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1377 if (!SCM_UNBNDP (end
))
1378 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1381 ans
= scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra
), port_or_fd
,
1382 scm_from_size_t (base
+ cstart
),
1383 scm_from_size_t (base
+ cend
));
1385 if (!scm_is_eq (cra
, ura
))
1386 scm_array_copy_x (cra
, ura
);
1389 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1390 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1392 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1396 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1397 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1398 "Writes all elements of @var{ura} as binary objects to\n"
1399 "@var{port-or-fdes}.\n\n"
1400 "The optional arguments @var{start}\n"
1401 "and @var{end} allow\n"
1402 "a specified region of a vector (or linearized array) to be written.\n\n"
1403 "The number of objects actually written is returned.\n"
1404 "@var{port-or-fdes} may be\n"
1405 "omitted, in which case it defaults to the value returned by\n"
1406 "@code{(current-output-port)}.")
1407 #define FUNC_NAME s_scm_uniform_array_write
1409 if (SCM_UNBNDP (port_or_fd
))
1410 port_or_fd
= scm_current_output_port ();
1412 if (scm_is_uniform_vector (ura
))
1414 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1416 else if (SCM_I_ARRAYP (ura
))
1418 size_t base
, vlen
, cstart
, cend
;
1421 cra
= scm_ra2contig (ura
, 1);
1422 base
= SCM_I_ARRAY_BASE (cra
);
1423 vlen
= SCM_I_ARRAY_DIMS (cra
)->inc
*
1424 (SCM_I_ARRAY_DIMS (cra
)->ubnd
- SCM_I_ARRAY_DIMS (cra
)->lbnd
+ 1);
1428 if (!SCM_UNBNDP (start
))
1430 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1431 if (!SCM_UNBNDP (end
))
1432 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1435 ans
= scm_uniform_vector_write (SCM_I_ARRAY_V (cra
), port_or_fd
,
1436 scm_from_size_t (base
+ cstart
),
1437 scm_from_size_t (base
+ cend
));
1441 else if (SCM_I_ENCLOSED_ARRAYP (ura
))
1442 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1444 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1451 static scm_t_bits scm_tc16_bitvector
;
1453 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1454 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1455 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1458 bitvector_free (SCM vec
)
1460 scm_gc_free (BITVECTOR_BITS (vec
),
1461 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1467 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1469 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1470 size_t word_len
= (bit_len
+31)/32;
1471 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1474 scm_puts ("#*", port
);
1475 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1477 scm_t_uint32 mask
= 1;
1478 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1479 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1486 bitvector_equalp (SCM vec1
, SCM vec2
)
1488 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1489 size_t word_len
= (bit_len
+ 31) / 32;
1490 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1491 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1492 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1494 /* compare lengths */
1495 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1497 /* avoid underflow in word_len-1 below. */
1500 /* compare full words */
1501 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1503 /* compare partial last words */
1504 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1510 scm_is_bitvector (SCM vec
)
1512 return IS_BITVECTOR (vec
);
1515 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1517 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1518 "return @code{#f}.")
1519 #define FUNC_NAME s_scm_bitvector_p
1521 return scm_from_bool (scm_is_bitvector (obj
));
1526 scm_c_make_bitvector (size_t len
, SCM fill
)
1528 size_t word_len
= (len
+ 31) / 32;
1532 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1534 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1536 if (!SCM_UNBNDP (fill
))
1537 scm_bitvector_fill_x (res
, fill
);
1542 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1543 (SCM len
, SCM fill
),
1544 "Create a new bitvector of length @var{len} and\n"
1545 "optionally initialize all elements to @var{fill}.")
1546 #define FUNC_NAME s_scm_make_bitvector
1548 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1552 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1554 "Create a new bitvector with the arguments as elements.")
1555 #define FUNC_NAME s_scm_bitvector
1557 return scm_list_to_bitvector (bits
);
1562 scm_c_bitvector_length (SCM vec
)
1564 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1565 return BITVECTOR_LENGTH (vec
);
1568 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1570 "Return the length of the bitvector @var{vec}.")
1571 #define FUNC_NAME s_scm_bitvector_length
1573 return scm_from_size_t (scm_c_bitvector_length (vec
));
1577 const scm_t_uint32
*
1578 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1580 return scm_array_handle_bit_writable_elements (h
);
1584 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1587 if (SCM_I_ARRAYP (vec
))
1588 vec
= SCM_I_ARRAY_V (vec
);
1589 if (IS_BITVECTOR (vec
))
1590 return BITVECTOR_BITS (vec
) + h
->base
/32;
1591 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1595 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1597 return h
->base
% 32;
1600 const scm_t_uint32
*
1601 scm_bitvector_elements (SCM vec
,
1602 scm_t_array_handle
*h
,
1607 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1612 scm_bitvector_writable_elements (SCM vec
,
1613 scm_t_array_handle
*h
,
1618 scm_generalized_vector_get_handle (vec
, h
);
1621 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1622 *offp
= scm_array_handle_bit_elements_offset (h
);
1623 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1626 return scm_array_handle_bit_writable_elements (h
);
1630 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1632 scm_t_array_handle handle
;
1633 const scm_t_uint32
*bits
;
1635 if (IS_BITVECTOR (vec
))
1637 if (idx
>= BITVECTOR_LENGTH (vec
))
1638 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1639 bits
= BITVECTOR_BITS(vec
);
1640 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1648 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1650 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1651 idx
= idx
*inc
+ off
;
1652 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1653 scm_array_handle_release (&handle
);
1658 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1660 "Return the element at index @var{idx} of the bitvector\n"
1662 #define FUNC_NAME s_scm_bitvector_ref
1664 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1669 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1671 scm_t_array_handle handle
;
1672 scm_t_uint32
*bits
, mask
;
1674 if (IS_BITVECTOR (vec
))
1676 if (idx
>= BITVECTOR_LENGTH (vec
))
1677 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1678 bits
= BITVECTOR_BITS(vec
);
1685 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1687 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1688 idx
= idx
*inc
+ off
;
1691 mask
= 1L << (idx
%32);
1692 if (scm_is_true (val
))
1693 bits
[idx
/32] |= mask
;
1695 bits
[idx
/32] &= ~mask
;
1697 if (!IS_BITVECTOR (vec
))
1698 scm_array_handle_release (&handle
);
1701 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1702 (SCM vec
, SCM idx
, SCM val
),
1703 "Set the element at index @var{idx} of the bitvector\n"
1704 "@var{vec} when @var{val} is true, else clear it.")
1705 #define FUNC_NAME s_scm_bitvector_set_x
1707 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1708 return SCM_UNSPECIFIED
;
1712 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1714 "Set all elements of the bitvector\n"
1715 "@var{vec} when @var{val} is true, else clear them.")
1716 #define FUNC_NAME s_scm_bitvector_fill_x
1718 scm_t_array_handle handle
;
1723 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1726 if (off
== 0 && inc
== 1 && len
> 0)
1730 size_t word_len
= (len
+ 31) / 32;
1731 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1733 if (scm_is_true (val
))
1735 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1736 bits
[word_len
-1] |= last_mask
;
1740 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1741 bits
[word_len
-1] &= ~last_mask
;
1747 for (i
= 0; i
< len
; i
++)
1748 scm_array_handle_set (&handle
, i
*inc
, val
);
1751 scm_array_handle_release (&handle
);
1753 return SCM_UNSPECIFIED
;
1757 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1759 "Return a new bitvector initialized with the elements\n"
1761 #define FUNC_NAME s_scm_list_to_bitvector
1763 size_t bit_len
= scm_to_size_t (scm_length (list
));
1764 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1765 size_t word_len
= (bit_len
+31)/32;
1766 scm_t_array_handle handle
;
1767 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1771 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1773 scm_t_uint32 mask
= 1;
1775 for (j
= 0; j
< 32 && j
< bit_len
;
1776 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1777 if (scm_is_true (SCM_CAR (list
)))
1781 scm_array_handle_release (&handle
);
1787 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1789 "Return a new list initialized with the elements\n"
1790 "of the bitvector @var{vec}.")
1791 #define FUNC_NAME s_scm_bitvector_to_list
1793 scm_t_array_handle handle
;
1799 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1802 if (off
== 0 && inc
== 1)
1806 size_t word_len
= (len
+ 31) / 32;
1809 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1811 scm_t_uint32 mask
= 1;
1812 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1813 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1819 for (i
= 0; i
< len
; i
++)
1820 res
= scm_cons (scm_array_handle_ref (&handle
, i
*inc
), res
);
1823 scm_array_handle_release (&handle
);
1825 return scm_reverse_x (res
, SCM_EOL
);
1829 /* From mmix-arith.w by Knuth.
1831 Here's a fun way to count the number of bits in a tetrabyte.
1833 [This classical trick is called the ``Gillies--Miller method for
1834 sideways addition'' in {\sl The Preparation of Programs for an
1835 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1836 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1837 the tricks used here were suggested by Balbir Singh, Peter
1838 Rossmanith, and Stefan Schwoon.]
1842 count_ones (scm_t_uint32 x
)
1844 x
=x
-((x
>>1)&0x55555555);
1845 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1846 x
=(x
+(x
>>4))&0x0f0f0f0f;
1848 return (x
+(x
>>16)) & 0xff;
1851 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1852 (SCM b
, SCM bitvector
),
1853 "Return the number of occurrences of the boolean @var{b} in\n"
1855 #define FUNC_NAME s_scm_bit_count
1857 scm_t_array_handle handle
;
1861 int bit
= scm_to_bool (b
);
1864 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1867 if (off
== 0 && inc
== 1 && len
> 0)
1871 size_t word_len
= (len
+ 31) / 32;
1872 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1875 for (i
= 0; i
< word_len
-1; i
++)
1876 count
+= count_ones (bits
[i
]);
1877 count
+= count_ones (bits
[i
] & last_mask
);
1882 for (i
= 0; i
< len
; i
++)
1883 if (scm_is_true (scm_array_handle_ref (&handle
, i
*inc
)))
1887 scm_array_handle_release (&handle
);
1889 return scm_from_size_t (bit
? count
: len
-count
);
1893 /* returns 32 for x == 0.
1896 find_first_one (scm_t_uint32 x
)
1899 /* do a binary search in x. */
1900 if ((x
& 0xFFFF) == 0)
1901 x
>>= 16, pos
+= 16;
1902 if ((x
& 0xFF) == 0)
1913 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1914 (SCM item
, SCM v
, SCM k
),
1915 "Return the index of the first occurrance of @var{item} in bit\n"
1916 "vector @var{v}, starting from @var{k}. If there is no\n"
1917 "@var{item} entry between @var{k} and the end of\n"
1918 "@var{bitvector}, then return @code{#f}. For example,\n"
1921 "(bit-position #t #*000101 0) @result{} 3\n"
1922 "(bit-position #f #*0001111 3) @result{} #f\n"
1924 #define FUNC_NAME s_scm_bit_position
1926 scm_t_array_handle handle
;
1927 size_t off
, len
, first_bit
;
1929 const scm_t_uint32
*bits
;
1930 int bit
= scm_to_bool (item
);
1931 SCM res
= SCM_BOOL_F
;
1933 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1934 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1936 if (off
== 0 && inc
== 1 && len
> 0)
1938 size_t i
, word_len
= (len
+ 31) / 32;
1939 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1940 size_t first_word
= first_bit
/ 32;
1941 scm_t_uint32 first_mask
=
1942 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1945 for (i
= first_word
; i
< word_len
; i
++)
1947 w
= (bit
? bits
[i
] : ~bits
[i
]);
1948 if (i
== first_word
)
1950 if (i
== word_len
-1)
1954 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1962 for (i
= first_bit
; i
< len
; i
++)
1964 SCM elt
= scm_array_handle_ref (&handle
, i
*inc
);
1965 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1967 res
= scm_from_size_t (i
);
1973 scm_array_handle_release (&handle
);
1979 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1980 (SCM v
, SCM kv
, SCM obj
),
1981 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1982 "selecting the entries to change. The return value is\n"
1985 "If @var{kv} is a bit vector, then those entries where it has\n"
1986 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1987 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1988 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1989 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1992 "(define bv #*01000010)\n"
1993 "(bit-set*! bv #*10010001 #t)\n"
1995 "@result{} #*11010011\n"
1998 "If @var{kv} is a u32vector, then its elements are\n"
1999 "indices into @var{v} which are set to @var{obj}.\n"
2002 "(define bv #*01000010)\n"
2003 "(bit-set*! bv #u32(5 2 7) #t)\n"
2005 "@result{} #*01100111\n"
2007 #define FUNC_NAME s_scm_bit_set_star_x
2009 scm_t_array_handle v_handle
;
2010 size_t v_off
, v_len
;
2012 scm_t_uint32
*v_bits
;
2015 /* Validate that OBJ is a boolean so this is done even if we don't
2018 bit
= scm_to_bool (obj
);
2020 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
2021 &v_off
, &v_len
, &v_inc
);
2023 if (scm_is_bitvector (kv
))
2025 scm_t_array_handle kv_handle
;
2026 size_t kv_off
, kv_len
;
2028 const scm_t_uint32
*kv_bits
;
2030 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2031 &kv_off
, &kv_len
, &kv_inc
);
2033 if (v_len
!= kv_len
)
2034 scm_misc_error (NULL
,
2035 "bit vectors must have equal length",
2038 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2040 size_t word_len
= (kv_len
+ 31) / 32;
2041 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2046 for (i
= 0; i
< word_len
-1; i
++)
2047 v_bits
[i
] &= ~kv_bits
[i
];
2048 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2052 for (i
= 0; i
< word_len
-1; i
++)
2053 v_bits
[i
] |= kv_bits
[i
];
2054 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2060 for (i
= 0; i
< kv_len
; i
++)
2061 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
*kv_inc
)))
2062 scm_array_handle_set (&v_handle
, i
*v_inc
, obj
);
2065 scm_array_handle_release (&kv_handle
);
2068 else if (scm_is_true (scm_u32vector_p (kv
)))
2070 scm_t_array_handle kv_handle
;
2073 const scm_t_uint32
*kv_elts
;
2075 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2076 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2077 scm_array_handle_set (&v_handle
, (*kv_elts
)*v_inc
, obj
);
2079 scm_array_handle_release (&kv_handle
);
2082 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2084 scm_array_handle_release (&v_handle
);
2086 return SCM_UNSPECIFIED
;
2091 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2092 (SCM v
, SCM kv
, SCM obj
),
2093 "Return a count of how many entries in bit vector @var{v} are\n"
2094 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2097 "If @var{kv} is a bit vector, then those entries where it has\n"
2098 "@code{#t} are the ones in @var{v} which are considered.\n"
2099 "@var{kv} and @var{v} must be the same length.\n"
2101 "If @var{kv} is a u32vector, then it contains\n"
2102 "the indexes in @var{v} to consider.\n"
2107 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2108 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2110 #define FUNC_NAME s_scm_bit_count_star
2112 scm_t_array_handle v_handle
;
2113 size_t v_off
, v_len
;
2115 const scm_t_uint32
*v_bits
;
2119 /* Validate that OBJ is a boolean so this is done even if we don't
2122 bit
= scm_to_bool (obj
);
2124 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2125 &v_off
, &v_len
, &v_inc
);
2127 if (scm_is_bitvector (kv
))
2129 scm_t_array_handle kv_handle
;
2130 size_t kv_off
, kv_len
;
2132 const scm_t_uint32
*kv_bits
;
2134 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2135 &kv_off
, &kv_len
, &kv_inc
);
2137 if (v_len
!= kv_len
)
2138 scm_misc_error (NULL
,
2139 "bit vectors must have equal length",
2142 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2144 size_t i
, word_len
= (kv_len
+ 31) / 32;
2145 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2146 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2148 for (i
= 0; i
< word_len
-1; i
++)
2149 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2150 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2155 for (i
= 0; i
< kv_len
; i
++)
2156 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2158 SCM elt
= scm_array_handle_ref (&v_handle
, i
*v_inc
);
2159 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2164 scm_array_handle_release (&kv_handle
);
2167 else if (scm_is_true (scm_u32vector_p (kv
)))
2169 scm_t_array_handle kv_handle
;
2172 const scm_t_uint32
*kv_elts
;
2174 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2175 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2177 SCM elt
= scm_array_handle_ref (&v_handle
, (*kv_elts
)*v_inc
);
2178 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2182 scm_array_handle_release (&kv_handle
);
2185 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2187 scm_array_handle_release (&v_handle
);
2189 return scm_from_size_t (count
);
2193 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2195 "Modify the bit vector @var{v} by replacing each element with\n"
2197 #define FUNC_NAME s_scm_bit_invert_x
2199 scm_t_array_handle handle
;
2204 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2206 if (off
== 0 && inc
== 1 && len
> 0)
2208 size_t word_len
= (len
+ 31) / 32;
2209 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2212 for (i
= 0; i
< word_len
-1; i
++)
2214 bits
[i
] = bits
[i
] ^ last_mask
;
2219 for (i
= 0; i
< len
; i
++)
2220 scm_array_handle_set (&handle
, i
*inc
,
2221 scm_not (scm_array_handle_ref (&handle
, i
*inc
)));
2224 scm_array_handle_release (&handle
);
2226 return SCM_UNSPECIFIED
;
2232 scm_istr2bve (SCM str
)
2234 scm_t_array_handle handle
;
2235 size_t len
= scm_i_string_length (str
);
2236 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2244 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2245 c_str
= scm_i_string_chars (str
);
2247 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2253 for (mask
= 1L; j
--; mask
<<= 1)
2268 scm_array_handle_release (&handle
);
2269 scm_remember_upto_here_1 (str
);
2276 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2281 int enclosed
= SCM_I_ENCLOSED_ARRAYP (ra
);
2283 if (k
== SCM_I_ARRAY_NDIM (ra
))
2284 return scm_i_cvref (SCM_I_ARRAY_V (ra
), base
, enclosed
);
2286 inc
= SCM_I_ARRAY_DIMS (ra
)[k
].inc
;
2287 if (SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
)
2289 i
= base
+ (1 + SCM_I_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_I_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2293 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2300 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2302 "Return a list consisting of all the elements, in order, of\n"
2304 #define FUNC_NAME s_scm_array_to_list
2306 if (scm_is_generalized_vector (v
))
2307 return scm_generalized_vector_to_list (v
);
2308 else if (SCM_I_ARRAYP (v
) || SCM_I_ENCLOSED_ARRAYP (v
))
2309 return ra2l (v
, SCM_I_ARRAY_BASE (v
), 0);
2311 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2316 static void l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
);
2318 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2319 (SCM type
, SCM shape
, SCM lst
),
2320 "Return an array of the type @var{type}\n"
2321 "with elements the same as those of @var{lst}.\n"
2323 "The argument @var{shape} determines the number of dimensions\n"
2324 "of the array and their shape. It is either an exact integer,\n"
2326 "number of dimensions directly, or a list whose length\n"
2327 "specifies the number of dimensions and each element specified\n"
2328 "the lower and optionally the upper bound of the corresponding\n"
2330 "When the element is list of two elements, these elements\n"
2331 "give the lower and upper bounds. When it is an exact\n"
2332 "integer, it gives only the lower bound.")
2333 #define FUNC_NAME s_scm_list_to_typed_array
2337 scm_t_array_handle handle
;
2340 if (scm_is_integer (shape
))
2342 size_t k
= scm_to_size_t (shape
);
2346 shape
= scm_cons (scm_length (row
), shape
);
2347 if (k
> 0 && !scm_is_null (row
))
2348 row
= scm_car (row
);
2353 SCM shape_spec
= shape
;
2357 SCM spec
= scm_car (shape_spec
);
2358 if (scm_is_pair (spec
))
2359 shape
= scm_cons (spec
, shape
);
2361 shape
= scm_cons (scm_list_2 (spec
,
2362 scm_sum (scm_sum (spec
,
2364 scm_from_int (-1))),
2366 shape_spec
= scm_cdr (shape_spec
);
2367 if (scm_is_pair (shape_spec
))
2369 if (!scm_is_null (row
))
2370 row
= scm_car (row
);
2377 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2378 scm_reverse_x (shape
, SCM_EOL
));
2380 scm_array_get_handle (ra
, &handle
);
2381 l2ra (lst
, &handle
, 0, 0);
2382 scm_array_handle_release (&handle
);
2388 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2389 (SCM ndim
, SCM lst
),
2390 "Return an array with elements the same as those of @var{lst}.")
2391 #define FUNC_NAME s_scm_list_to_array
2393 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2398 l2ra (SCM lst
, scm_t_array_handle
*handle
, ssize_t pos
, size_t k
)
2400 if (k
== scm_array_handle_rank (handle
))
2401 scm_array_handle_set (handle
, pos
, lst
);
2404 scm_t_array_dim
*dim
= scm_array_handle_dims (handle
) + k
;
2405 ssize_t inc
= dim
->inc
;
2406 size_t len
= 1 + dim
->ubnd
- dim
->lbnd
, n
;
2407 char *errmsg
= NULL
;
2410 while (n
> 0 && scm_is_pair (lst
))
2412 l2ra (SCM_CAR (lst
), handle
, pos
, k
+ 1);
2414 lst
= SCM_CDR (lst
);
2418 errmsg
= "too few elements for array dimension ~a, need ~a";
2419 if (!scm_is_null (lst
))
2420 errmsg
= "too many elements for array dimension ~a, want ~a";
2422 scm_misc_error (NULL
, errmsg
, scm_list_2 (scm_from_ulong (k
),
2423 scm_from_size_t (len
)));
2427 #if SCM_ENABLE_DEPRECATED
2429 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2430 (SCM ndim
, SCM prot
, SCM lst
),
2431 "Return a uniform array of the type indicated by prototype\n"
2432 "@var{prot} with elements the same as those of @var{lst}.\n"
2433 "Elements must be of the appropriate type, no coercions are\n"
2436 "The argument @var{ndim} determines the number of dimensions\n"
2437 "of the array. It is either an exact integer, giving the\n"
2438 "number directly, or a list of exact integers, whose length\n"
2439 "specifies the number of dimensions and each element is the\n"
2440 "lower index bound of its dimension.")
2441 #define FUNC_NAME s_scm_list_to_uniform_array
2443 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2449 /* Print dimension DIM of ARRAY.
2453 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2454 SCM port
, scm_print_state
*pstate
)
2456 scm_t_array_dim
*dim_spec
= SCM_I_ARRAY_DIMS (array
) + dim
;
2459 scm_putc ('(', port
);
2461 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2463 if (dim
< SCM_I_ARRAY_NDIM(array
)-1)
2464 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2467 scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array
), base
, enclosed
),
2469 if (idx
< dim_spec
->ubnd
)
2470 scm_putc (' ', port
);
2471 base
+= dim_spec
->inc
;
2474 scm_putc (')', port
);
2478 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2482 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2484 long ndim
= SCM_I_ARRAY_NDIM (array
);
2485 scm_t_array_dim
*dim_specs
= SCM_I_ARRAY_DIMS (array
);
2486 SCM v
= SCM_I_ARRAY_V (array
);
2487 unsigned long base
= SCM_I_ARRAY_BASE (array
);
2489 int print_lbnds
= 0, zero_size
= 0, print_lens
= 0;
2491 scm_putc ('#', port
);
2492 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2493 scm_intprint (ndim
, 10, port
);
2494 if (scm_is_uniform_vector (v
))
2495 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2496 else if (scm_is_bitvector (v
))
2497 scm_puts ("b", port
);
2498 else if (scm_is_string (v
))
2499 scm_puts ("a", port
);
2500 else if (!scm_is_vector (v
))
2501 scm_puts ("?", port
);
2503 for (i
= 0; i
< ndim
; i
++)
2505 if (dim_specs
[i
].lbnd
!= 0)
2507 if (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1 == 0)
2513 if (print_lbnds
|| print_lens
)
2514 for (i
= 0; i
< ndim
; i
++)
2518 scm_putc ('@', port
);
2519 scm_intprint (dim_specs
[i
].lbnd
, 10, port
);
2523 scm_putc (':', port
);
2524 scm_intprint (dim_specs
[i
].ubnd
- dim_specs
[i
].lbnd
+ 1,
2531 /* Rank zero arrays, which are really just scalars, are printed
2532 specially. The consequent way would be to print them as
2536 where OBJ is the printed representation of the scalar, but we
2537 print them instead as
2541 to make them look less strange.
2543 Just printing them as
2547 would be correct in a way as well, but zero rank arrays are
2548 not really the same as Scheme values since they are boxed and
2549 can be modified with array-set!, say.
2551 scm_putc ('(', port
);
2552 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2553 scm_putc (')', port
);
2557 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2561 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2565 scm_putc ('#', port
);
2566 base
= SCM_I_ARRAY_BASE (array
);
2567 scm_puts ("<enclosed-array ", port
);
2568 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2569 scm_putc ('>', port
);
2573 /* Read an array. This function can also read vectors and uniform
2574 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2577 C is the first character read after the '#'.
2581 tag_to_type (const char *tag
, SCM port
)
2583 #if SCM_ENABLE_DEPRECATED
2585 /* Recognize the old syntax.
2587 const char *instead
;
2619 if (instead
&& tag
[1] == '\0')
2621 scm_c_issue_deprecation_warning_fmt
2622 ("The tag '%c' is deprecated for uniform vectors. "
2623 "Use '%s' instead.", tag
[0], instead
);
2624 return scm_from_locale_symbol (instead
);
2632 return scm_from_locale_symbol (tag
);
2636 read_decimal_integer (SCM port
, int c
, ssize_t
*resp
)
2645 c
= scm_getc (port
);
2648 while ('0' <= c
&& c
<= '9')
2650 res
= 10*res
+ c
-'0';
2652 c
= scm_getc (port
);
2661 scm_i_read_array (SCM port
, int c
)
2668 SCM shape
= SCM_BOOL_F
, elements
;
2670 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2671 the array code can not deal with zero-length dimensions yet, and
2672 we want to allow zero-length vectors, of course.
2676 scm_ungetc (c
, port
);
2677 return scm_vector (scm_read (port
));
2680 /* Disambiguate between '#f' and uniform floating point vectors.
2684 c
= scm_getc (port
);
2685 if (c
!= '3' && c
!= '6')
2688 scm_ungetc (c
, port
);
2695 goto continue_reading_tag
;
2701 c
= read_decimal_integer (port
, c
, &rank
);
2703 scm_i_input_error (NULL
, port
, "array rank must be non-negative",
2709 continue_reading_tag
:
2710 while (c
!= EOF
&& c
!= '(' && c
!= '@' && c
!= ':' && tag_len
< 80)
2713 c
= scm_getc (port
);
2715 tag
[tag_len
] = '\0';
2719 if (c
== '@' || c
== ':')
2725 ssize_t lbnd
= 0, len
= 0;
2730 c
= scm_getc (port
);
2731 c
= read_decimal_integer (port
, c
, &lbnd
);
2734 s
= scm_from_ssize_t (lbnd
);
2738 c
= scm_getc (port
);
2739 c
= read_decimal_integer (port
, c
, &len
);
2740 s
= scm_list_2 (s
, scm_from_ssize_t (lbnd
+len
-1));
2743 shape
= scm_cons (s
, shape
);
2744 } while (c
== '@' || c
== ':');
2746 shape
= scm_reverse_x (shape
, SCM_EOL
);
2749 /* Read nested lists of elements.
2752 scm_i_input_error (NULL
, port
,
2753 "missing '(' in vector or array literal",
2755 scm_ungetc (c
, port
);
2756 elements
= scm_read (port
);
2758 if (scm_is_false (shape
))
2759 shape
= scm_from_ssize_t (rank
);
2760 else if (scm_ilength (shape
) != rank
)
2763 "the number of shape specifications must match the array rank",
2766 /* Handle special print syntax of rank zero arrays; see
2767 scm_i_print_array for a rationale.
2771 if (!scm_is_pair (elements
))
2772 scm_i_input_error (NULL
, port
,
2773 "too few elements in array literal, need 1",
2775 if (!scm_is_null (SCM_CDR (elements
)))
2776 scm_i_input_error (NULL
, port
,
2777 "too many elements in array literal, want 1",
2779 elements
= SCM_CAR (elements
);
2784 return scm_list_to_typed_array (tag_to_type (tag
, port
), shape
, elements
);
2787 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2790 #define FUNC_NAME s_scm_array_type
2792 if (SCM_I_ARRAYP (ra
))
2793 return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra
));
2794 else if (scm_is_generalized_vector (ra
))
2795 return scm_i_generalized_vector_type (ra
);
2796 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2797 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2799 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2803 #if SCM_ENABLE_DEPRECATED
2805 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2807 "Return an object that would produce an array of the same type\n"
2808 "as @var{array}, if used as the @var{prototype} for\n"
2809 "@code{make-uniform-array}.")
2810 #define FUNC_NAME s_scm_array_prototype
2812 if (SCM_I_ARRAYP (ra
))
2813 return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra
));
2814 else if (scm_is_generalized_vector (ra
))
2815 return scm_i_get_old_prototype (ra
);
2816 else if (SCM_I_ENCLOSED_ARRAYP (ra
))
2817 return SCM_UNSPECIFIED
;
2819 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2826 array_mark (SCM ptr
)
2828 return SCM_I_ARRAY_V (ptr
);
2832 array_free (SCM ptr
)
2834 scm_gc_free (SCM_I_ARRAY_MEM (ptr
),
2835 (sizeof (scm_i_t_array
)
2836 + SCM_I_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2841 #if SCM_ENABLE_DEPRECATED
2844 scm_make_ra (int ndim
)
2846 scm_c_issue_deprecation_warning
2847 ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
2848 return scm_i_make_ra (ndim
, 0);
2852 scm_shap2ra (SCM args
, const char *what
)
2854 scm_c_issue_deprecation_warning
2855 ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
2856 return scm_i_shap2ra (args
);
2860 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
2862 scm_c_issue_deprecation_warning
2863 ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
2864 return scm_c_generalized_vector_ref (v
, pos
);
2868 scm_ra_set_contp (SCM ra
)
2870 scm_c_issue_deprecation_warning
2871 ("scm_ra_set_contp is deprecated. There should be no need for it.");
2872 scm_i_ra_set_contp (ra
);
2876 scm_aind (SCM ra
, SCM args
, const char *what
)
2878 scm_t_array_handle handle
;
2881 scm_c_issue_deprecation_warning
2882 ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
2884 if (scm_is_integer (args
))
2885 args
= scm_list_1 (args
);
2887 scm_array_get_handle (ra
, &handle
);
2888 pos
= scm_array_handle_pos (&handle
, args
) + SCM_I_ARRAY_BASE (ra
);
2889 scm_array_handle_release (&handle
);
2894 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2896 scm_c_issue_deprecation_warning
2897 ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
2899 scm_iprin1 (exp
, port
, pstate
);
2908 scm_i_tc16_array
= scm_make_smob_type ("array", 0);
2909 scm_set_smob_mark (scm_i_tc16_array
, array_mark
);
2910 scm_set_smob_free (scm_i_tc16_array
, array_free
);
2911 scm_set_smob_print (scm_i_tc16_array
, scm_i_print_array
);
2912 scm_set_smob_equalp (scm_i_tc16_array
, scm_array_equal_p
);
2914 scm_i_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2915 scm_set_smob_mark (scm_i_tc16_enclosed_array
, array_mark
);
2916 scm_set_smob_free (scm_i_tc16_enclosed_array
, array_free
);
2917 scm_set_smob_print (scm_i_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2918 scm_set_smob_equalp (scm_i_tc16_enclosed_array
, scm_array_equal_p
);
2920 scm_add_feature ("array");
2922 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2923 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2924 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2925 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2927 init_type_creator_table ();
2929 #include "libguile/unif.x"