1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
36 #include "libguile/_scm.h"
37 #include "libguile/__scm.h"
38 #include "libguile/eq.h"
39 #include "libguile/chars.h"
40 #include "libguile/eval.h"
41 #include "libguile/fports.h"
42 #include "libguile/smob.h"
43 #include "libguile/feature.h"
44 #include "libguile/root.h"
45 #include "libguile/strings.h"
46 #include "libguile/srfi-13.h"
47 #include "libguile/srfi-4.h"
48 #include "libguile/vectors.h"
49 #include "libguile/list.h"
50 #include "libguile/deprecation.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/unif.h"
55 #include "libguile/ramap.h"
56 #include "libguile/print.h"
57 #include "libguile/read.h"
68 /* The set of uniform scm_vector types is:
69 * Vector of: Called: Replaced by:
70 * unsigned char string
71 * char byvect s8 or u8, depending on signedness of 'char'
73 * signed long ivect s32
74 * unsigned long uvect u32
77 * complex double cvect c64
79 * long long llvect s64
82 scm_t_bits scm_tc16_array
;
83 scm_t_bits scm_tc16_enclosed_array
;
85 typedef SCM
creator_proc (SCM len
, SCM fill
);
90 creator_proc
*creator
;
91 } type_creator_table
[] = {
92 { "a", SCM_UNSPECIFIED
, scm_make_string
},
93 { "b", SCM_UNSPECIFIED
, scm_make_bitvector
},
94 { "u8", SCM_UNSPECIFIED
, scm_make_u8vector
},
95 { "s8", SCM_UNSPECIFIED
, scm_make_s8vector
},
96 { "u16", SCM_UNSPECIFIED
, scm_make_u16vector
},
97 { "s16", SCM_UNSPECIFIED
, scm_make_s16vector
},
98 { "u32", SCM_UNSPECIFIED
, scm_make_u32vector
},
99 { "s32", SCM_UNSPECIFIED
, scm_make_s32vector
},
100 { "u64", SCM_UNSPECIFIED
, scm_make_u64vector
},
101 { "s64", SCM_UNSPECIFIED
, scm_make_s64vector
},
102 { "f32", SCM_UNSPECIFIED
, scm_make_f32vector
},
103 { "f64", SCM_UNSPECIFIED
, scm_make_f64vector
},
104 { "c32", SCM_UNSPECIFIED
, scm_make_c32vector
},
105 { "c64", SCM_UNSPECIFIED
, scm_make_c64vector
},
110 init_type_creator_table ()
113 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
115 SCM sym
= scm_from_locale_symbol (type_creator_table
[i
].type_name
);
116 type_creator_table
[i
].type
= scm_permanent_object (sym
);
120 static creator_proc
*
121 type_to_creator (SCM type
)
125 if (scm_is_eq (type
, SCM_BOOL_T
))
126 return scm_make_vector
;
127 for (i
= 0; type_creator_table
[i
].type_name
; i
++)
128 if (scm_is_eq (type
, type_creator_table
[i
].type
))
129 return type_creator_table
[i
].creator
;
131 scm_misc_error (NULL
, "unknown array type: ~a", scm_list_1 (type
));
135 make_typed_vector (SCM type
, size_t len
)
137 creator_proc
*creator
= type_to_creator (type
);
138 return creator (scm_from_size_t (len
), SCM_UNDEFINED
);
141 #if SCM_ENABLE_DEPRECATED
143 SCM_SYMBOL (scm_sym_s
, "s");
144 SCM_SYMBOL (scm_sym_l
, "l");
147 prototype_to_type (SCM proto
)
149 const char *type_name
;
151 if (scm_is_eq (proto
, SCM_BOOL_T
))
153 else if (scm_is_eq (proto
, SCM_MAKE_CHAR ('a')))
155 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
157 else if (scm_is_eq (proto
, scm_sym_s
))
159 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (1))))
161 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (-1))))
163 else if (scm_is_eq (proto
, scm_sym_l
))
165 else if (scm_is_true (scm_eqv_p (proto
, scm_from_double (1.0))))
167 else if (scm_is_true (scm_eqv_p (proto
, scm_divide (scm_from_int (1),
170 else if (scm_is_true (scm_eqv_p (proto
, scm_c_make_rectangular (0, 1))))
172 else if (scm_is_null (proto
))
178 return scm_from_locale_symbol (type_name
);
184 scm_i_get_old_prototype (SCM uvec
)
186 if (scm_is_bitvector (uvec
))
188 else if (scm_is_string (uvec
))
189 return SCM_MAKE_CHAR ('a');
190 else if (scm_is_true (scm_s8vector_p (uvec
)))
191 return SCM_MAKE_CHAR ('\0');
192 else if (scm_is_true (scm_s16vector_p (uvec
)))
194 else if (scm_is_true (scm_u32vector_p (uvec
)))
195 return scm_from_int (1);
196 else if (scm_is_true (scm_s32vector_p (uvec
)))
197 return scm_from_int (-1);
198 else if (scm_is_true (scm_s64vector_p (uvec
)))
200 else if (scm_is_true (scm_f32vector_p (uvec
)))
201 return scm_from_double (1.0);
202 else if (scm_is_true (scm_f64vector_p (uvec
)))
203 return scm_divide (scm_from_int (1), scm_from_int (3));
204 else if (scm_is_true (scm_c64vector_p (uvec
)))
205 return scm_c_make_rectangular (0, 1);
206 else if (scm_is_vector (uvec
))
209 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
213 scm_make_uve (long k
, SCM prot
)
214 #define FUNC_NAME "scm_make_uve"
216 scm_c_issue_deprecation_warning
217 ("`scm_make_uve' is deprecated, see the manual for alternatives.");
219 return make_typed_vector (prototype_to_type (prot
), k
);
226 scm_is_array (SCM obj
)
228 return (SCM_ENCLOSED_ARRAYP (obj
)
230 || scm_is_generalized_vector (obj
));
234 scm_is_typed_array (SCM obj
, SCM type
)
236 if (SCM_ENCLOSED_ARRAYP (obj
))
238 /* Enclosed arrays are arrays but are not of any type.
243 /* Get storage vector.
245 if (SCM_ARRAYP (obj
))
246 obj
= SCM_ARRAY_V (obj
);
248 /* It must be a generalized vector (which includes vectors, strings, etc).
250 if (!scm_is_generalized_vector (obj
))
253 return scm_is_eq (type
, scm_i_generalized_vector_type (obj
));
257 scm_array_get_handle (SCM array
, scm_t_array_handle
*h
)
260 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
262 h
->dims
= SCM_ARRAY_DIMS (array
);
263 h
->base
= SCM_ARRAY_BASE (array
);
265 else if (scm_is_generalized_vector (array
))
268 h
->dim0
.ubnd
= scm_c_generalized_vector_length (array
) - 1;
274 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
278 scm_array_handle_release (scm_t_array_handle
*h
)
280 /* Nothing to do here until arrays need to be reserved for real.
285 scm_array_handle_rank (scm_t_array_handle
*h
)
287 if (SCM_ARRAYP (h
->array
) || SCM_ENCLOSED_ARRAYP (h
->array
))
288 return SCM_ARRAY_NDIM (h
->array
);
294 scm_array_handle_dims (scm_t_array_handle
*h
)
300 scm_array_handle_ref (scm_t_array_handle
*h
, ssize_t pos
)
303 if (SCM_ARRAYP (h
->array
))
304 return scm_i_cvref (SCM_ARRAY_V (h
->array
), pos
, 0);
305 if (SCM_ENCLOSED_ARRAYP (h
->array
))
306 return scm_i_cvref (SCM_ARRAY_V (h
->array
), pos
, 1);
307 return scm_c_generalized_vector_ref (h
->array
, pos
);
311 scm_array_handle_set (scm_t_array_handle
*h
, ssize_t pos
, SCM val
)
314 if (SCM_ARRAYP (h
->array
))
315 scm_c_generalized_vector_set_x (SCM_ARRAY_V (h
->array
), pos
, val
);
316 if (SCM_ENCLOSED_ARRAYP (h
->array
))
317 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-enclosed array");
318 scm_c_generalized_vector_set_x (h
->array
, pos
, val
);
322 scm_array_handle_elements (scm_t_array_handle
*h
)
325 if (SCM_ARRAYP (vec
))
326 vec
= SCM_ARRAY_V (vec
);
327 if (SCM_I_IS_VECTOR (vec
))
328 return SCM_I_VECTOR_ELTS (vec
) + h
->base
;
329 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
333 scm_array_handle_writable_elements (scm_t_array_handle
*h
)
336 if (SCM_ARRAYP (vec
))
337 vec
= SCM_ARRAY_V (vec
);
338 if (SCM_I_IS_VECTOR (vec
))
339 return SCM_I_VECTOR_WELTS (vec
) + h
->base
;
340 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "non-uniform array");
343 #if SCM_ENABLE_DEPRECATED
345 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
347 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
349 #define FUNC_NAME s_scm_array_p
351 if (!SCM_UNBNDP (prot
))
353 scm_c_issue_deprecation_warning
354 ("Using prototypes with `array?' is deprecated."
355 " Use `typed-array?' instead.");
357 return scm_typed_array_p (obj
, prototype_to_type (prot
));
360 return scm_from_bool (scm_is_array (obj
));
364 #else /* !SCM_ENABLE_DEPRECATED */
366 /* We keep the old 2-argument C prototype for a while although the old
367 PROT argument is always ignored now. C code should probably use
368 scm_is_array or scm_is_typed_array anyway.
371 static SCM
scm_i_array_p (SCM obj
);
373 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
375 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
377 #define FUNC_NAME s_scm_i_array_p
379 return scm_from_bool (scm_is_array (obj
));
384 scm_array_p (SCM obj
, SCM prot
)
386 return scm_from_bool (scm_is_array (obj
));
389 #endif /* !SCM_ENABLE_DEPRECATED */
392 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
394 "Return @code{#t} if the @var{obj} is an array of type\n"
395 "@var{type}, and @code{#f} if not.")
396 #define FUNC_NAME s_scm_typed_array_p
398 return scm_from_bool (scm_is_typed_array (obj
, type
));
403 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
405 "Return the number of dimensions of the array @var{array.}\n")
406 #define FUNC_NAME s_scm_array_rank
408 if (scm_is_generalized_vector (array
))
409 return scm_from_int (1);
411 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
412 return scm_from_size_t (SCM_ARRAY_NDIM (array
));
414 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
419 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
421 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
422 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
424 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
426 #define FUNC_NAME s_scm_array_dimensions
428 if (scm_is_generalized_vector (ra
))
429 return scm_list_1 (scm_generalized_vector_length (ra
));
431 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
437 k
= SCM_ARRAY_NDIM (ra
);
438 s
= SCM_ARRAY_DIMS (ra
);
440 res
= scm_cons (s
[k
].lbnd
441 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
442 scm_from_long (s
[k
].ubnd
),
444 : scm_from_long (1 + s
[k
].ubnd
),
449 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
454 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
456 "Return the root vector of a shared array.")
457 #define FUNC_NAME s_scm_shared_array_root
459 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
460 SCM_ARG1
, FUNC_NAME
);
461 return SCM_ARRAY_V (ra
);
466 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
468 "Return the root vector index of the first element in the array.")
469 #define FUNC_NAME s_scm_shared_array_offset
471 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
472 SCM_ARG1
, FUNC_NAME
);
473 return scm_from_int (SCM_ARRAY_BASE (ra
));
478 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
480 "For each dimension, return the distance between elements in the root vector.")
481 #define FUNC_NAME s_scm_shared_array_increments
487 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
488 SCM_ARG1
, FUNC_NAME
);
489 k
= SCM_ARRAY_NDIM (ra
);
490 s
= SCM_ARRAY_DIMS (ra
);
492 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
498 static char s_bad_ind
[] = "Bad scm_array index";
502 scm_aind (SCM ra
, SCM args
, const char *what
)
506 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
507 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
508 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
510 if (scm_is_integer (args
))
513 scm_error_num_args_subr (what
);
514 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
516 while (k
&& scm_is_pair (args
))
518 ind
= SCM_CAR (args
);
519 args
= SCM_CDR (args
);
520 if (!scm_is_integer (ind
))
521 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
522 j
= scm_to_long (ind
);
523 if (j
< s
->lbnd
|| j
> s
->ubnd
)
524 scm_out_of_range (what
, ind
);
525 pos
+= (j
- s
->lbnd
) * (s
->inc
);
529 if (k
!= 0 || !scm_is_null (args
))
530 scm_error_num_args_subr (what
);
537 scm_i_make_ra (int ndim
, scm_t_bits tag
)
540 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
541 scm_gc_malloc ((sizeof (scm_t_array
) +
542 ndim
* sizeof (scm_t_array_dim
)),
544 SCM_ARRAY_V (ra
) = SCM_BOOL_F
;
549 scm_make_ra (int ndim
)
551 return scm_i_make_ra (ndim
, scm_tc16_array
);
555 static char s_bad_spec
[] = "Bad scm_array dimension";
558 /* Increments will still need to be set. */
561 scm_shap2ra (SCM args
, const char *what
)
565 int ndim
= scm_ilength (args
);
567 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
569 ra
= scm_make_ra (ndim
);
570 SCM_ARRAY_BASE (ra
) = 0;
571 s
= SCM_ARRAY_DIMS (ra
);
572 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
574 spec
= SCM_CAR (args
);
575 if (scm_is_integer (spec
))
577 if (scm_to_long (spec
) < 0)
578 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
580 s
->ubnd
= scm_to_long (spec
) - 1;
585 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
586 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
587 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
589 if (!scm_is_pair (sp
)
590 || !scm_is_integer (SCM_CAR (sp
))
591 || !scm_is_null (SCM_CDR (sp
)))
592 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
593 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
600 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
601 (SCM type
, SCM fill
, SCM bounds
),
602 "Create and return an array of type @var{type}.")
603 #define FUNC_NAME s_scm_make_typed_array
607 creator_proc
*creator
;
610 creator
= type_to_creator (type
);
611 ra
= scm_shap2ra (bounds
, FUNC_NAME
);
612 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
613 s
= SCM_ARRAY_DIMS (ra
);
614 k
= SCM_ARRAY_NDIM (ra
);
619 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
);
620 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
623 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
624 fill
= SCM_UNDEFINED
;
626 SCM_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
628 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
629 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
630 return SCM_ARRAY_V (ra
);
635 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
636 (SCM fill
, SCM bounds
),
637 "Create and return an array.")
638 #define FUNC_NAME s_scm_make_array
640 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
644 #if SCM_ENABLE_DEPRECATED
646 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
647 (SCM dims
, SCM prot
, SCM fill
),
648 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
649 "Create and return a uniform array or vector of type\n"
650 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
651 "length @var{length}. If @var{fill} is supplied, it's used to\n"
652 "fill the array, otherwise @var{prototype} is used.")
653 #define FUNC_NAME s_scm_dimensions_to_uniform_array
655 scm_c_issue_deprecation_warning
656 ("`dimensions->uniform-array' is deprecated. "
657 "Use `make-typed-array' instead.");
659 if (scm_is_integer (dims
))
660 dims
= scm_list_1 (dims
);
661 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
668 scm_ra_set_contp (SCM ra
)
670 /* XXX - correct? one-dimensional arrays are always 'contiguous',
673 size_t k
= SCM_ARRAY_NDIM (ra
);
676 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
679 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
681 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
684 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
685 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
688 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
692 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
693 (SCM oldra
, SCM mapfunc
, SCM dims
),
694 "@code{make-shared-array} can be used to create shared subarrays of other\n"
695 "arrays. The @var{mapper} is a function that translates coordinates in\n"
696 "the new array into coordinates in the old array. A @var{mapper} must be\n"
697 "linear, and its range must stay within the bounds of the old array, but\n"
698 "it can be otherwise arbitrary. A simple example:\n"
700 "(define fred (make-array #f 8 8))\n"
701 "(define freds-diagonal\n"
702 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
703 "(array-set! freds-diagonal 'foo 3)\n"
704 "(array-ref fred 3 3) @result{} foo\n"
705 "(define freds-center\n"
706 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
707 "(array-ref freds-center 0 0) @result{} foo\n"
709 #define FUNC_NAME s_scm_make_shared_array
715 long old_min
, new_min
, old_max
, new_max
;
718 SCM_VALIDATE_REST_ARGUMENT (dims
);
719 SCM_VALIDATE_ARRAY (1, oldra
);
720 SCM_VALIDATE_PROC (2, mapfunc
);
721 ra
= scm_shap2ra (dims
, FUNC_NAME
);
722 if (SCM_ARRAYP (oldra
))
724 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
725 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
726 s
= SCM_ARRAY_DIMS (oldra
);
727 k
= SCM_ARRAY_NDIM (oldra
);
731 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
733 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
738 SCM_ARRAY_V (ra
) = oldra
;
740 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
743 s
= SCM_ARRAY_DIMS (ra
);
744 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
746 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
747 if (s
[k
].ubnd
< s
[k
].lbnd
)
749 if (1 == SCM_ARRAY_NDIM (ra
))
750 ra
= make_typed_vector (scm_array_type (ra
), 0);
752 SCM_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
756 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
757 if (SCM_ARRAYP (oldra
))
758 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
761 if (!scm_is_integer (imap
))
763 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
764 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
765 imap
= SCM_CAR (imap
);
767 i
= scm_to_size_t (imap
);
769 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
771 k
= SCM_ARRAY_NDIM (ra
);
774 if (s
[k
].ubnd
> s
[k
].lbnd
)
776 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
777 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
778 if (SCM_ARRAYP (oldra
))
780 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
783 if (!scm_is_integer (imap
))
785 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
786 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
787 imap
= SCM_CAR (imap
);
789 s
[k
].inc
= scm_to_long (imap
) - i
;
793 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
795 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
798 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
799 indptr
= SCM_CDR (indptr
);
801 if (old_min
> new_min
|| old_max
< new_max
)
802 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
803 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
805 SCM v
= SCM_ARRAY_V (ra
);
806 size_t length
= scm_c_generalized_vector_length (v
);
807 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
809 if (s
->ubnd
< s
->lbnd
)
810 return make_typed_vector (scm_array_type (ra
), 0);
812 scm_ra_set_contp (ra
);
818 /* args are RA . DIMS */
819 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
821 "Return an array sharing contents with @var{array}, but with\n"
822 "dimensions arranged in a different order. There must be one\n"
823 "@var{dim} argument for each dimension of @var{array}.\n"
824 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
825 "and the rank of the array to be returned. Each integer in that\n"
826 "range must appear at least once in the argument list.\n"
828 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
829 "dimensions in the array to be returned, their positions in the\n"
830 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
831 "may have the same value, in which case the returned array will\n"
832 "have smaller rank than @var{array}.\n"
835 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
836 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
837 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
838 " #2((a 4) (b 5) (c 6))\n"
840 #define FUNC_NAME s_scm_transpose_array
843 scm_t_array_dim
*s
, *r
;
846 SCM_VALIDATE_REST_ARGUMENT (args
);
847 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
849 if (scm_is_generalized_vector (ra
))
851 /* Make sure that we are called with a single zero as
854 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
855 SCM_WRONG_NUM_ARGS ();
856 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
857 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
861 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
863 vargs
= scm_vector (args
);
864 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
865 SCM_WRONG_NUM_ARGS ();
867 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
869 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
870 0, SCM_ARRAY_NDIM(ra
));
875 res
= scm_make_ra (ndim
);
876 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
877 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
880 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
881 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
883 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
885 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
886 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
887 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
888 if (r
->ubnd
< r
->lbnd
)
897 if (r
->ubnd
> s
->ubnd
)
899 if (r
->lbnd
< s
->lbnd
)
901 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
908 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
909 scm_ra_set_contp (res
);
913 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
917 /* args are RA . AXES */
918 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
920 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
921 "the rank of @var{array}. @var{enclose-array} returns an array\n"
922 "resembling an array of shared arrays. The dimensions of each shared\n"
923 "array are the same as the @var{dim}th dimensions of the original array,\n"
924 "the dimensions of the outer array are the same as those of the original\n"
925 "array that did not match a @var{dim}.\n\n"
926 "An enclosed array is not a general Scheme array. Its elements may not\n"
927 "be set using @code{array-set!}. Two references to the same element of\n"
928 "an enclosed array will be @code{equal?} but will not in general be\n"
929 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
930 "enclosed array is unspecified.\n\n"
933 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
934 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
935 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
936 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
938 #define FUNC_NAME s_scm_enclose_array
940 SCM axv
, res
, ra_inr
;
942 scm_t_array_dim vdim
, *s
= &vdim
;
943 int ndim
, j
, k
, ninr
, noutr
;
945 SCM_VALIDATE_REST_ARGUMENT (axes
);
946 if (scm_is_null (axes
))
947 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
948 ninr
= scm_ilength (axes
);
950 SCM_WRONG_NUM_ARGS ();
951 ra_inr
= scm_make_ra (ninr
);
953 if (scm_is_generalized_vector (ra
))
956 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
958 SCM_ARRAY_V (ra_inr
) = ra
;
959 SCM_ARRAY_BASE (ra_inr
) = 0;
962 else if (SCM_ARRAYP (ra
))
964 s
= SCM_ARRAY_DIMS (ra
);
965 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
966 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
967 ndim
= SCM_ARRAY_NDIM (ra
);
970 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
974 SCM_WRONG_NUM_ARGS ();
975 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
976 res
= scm_i_make_ra (noutr
, scm_tc16_enclosed_array
);
977 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
978 SCM_ARRAY_V (res
) = ra_inr
;
979 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
981 if (!scm_is_integer (SCM_CAR (axes
)))
982 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
983 j
= scm_to_int (SCM_CAR (axes
));
984 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
985 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
986 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
987 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
989 c_axv
= scm_i_string_chars (axv
);
990 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
994 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
995 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
996 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
998 scm_remember_upto_here_1 (axv
);
999 scm_ra_set_contp (ra_inr
);
1000 scm_ra_set_contp (res
);
1007 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1009 "Return @code{#t} if its arguments would be acceptable to\n"
1010 "@code{array-ref}.")
1011 #define FUNC_NAME s_scm_array_in_bounds_p
1013 SCM res
= SCM_BOOL_T
;
1015 SCM_VALIDATE_REST_ARGUMENT (args
);
1017 if (scm_is_generalized_vector (v
))
1021 if (!scm_is_pair (args
))
1022 SCM_WRONG_NUM_ARGS ();
1023 ind
= scm_to_long (SCM_CAR (args
));
1024 args
= SCM_CDR (args
);
1025 res
= scm_from_bool (ind
>= 0
1026 && ind
< scm_c_generalized_vector_length (v
));
1028 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1030 size_t k
= SCM_ARRAY_NDIM (v
);
1031 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (v
);
1037 if (!scm_is_pair (args
))
1038 SCM_WRONG_NUM_ARGS ();
1039 ind
= scm_to_long (SCM_CAR (args
));
1040 args
= SCM_CDR (args
);
1043 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1046 /* We do not stop the checking after finding a violation
1047 since we want to validate the type-correctness and
1048 number of arguments in any case.
1054 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1056 if (!scm_is_null (args
))
1057 SCM_WRONG_NUM_ARGS ();
1064 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1068 int k
= SCM_ARRAY_NDIM (v
);
1069 SCM res
= scm_make_ra (k
);
1070 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1071 SCM_ARRAY_BASE (res
) = pos
;
1074 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1075 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1076 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1081 return scm_c_generalized_vector_ref (v
, pos
);
1085 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1087 return scm_i_cvref (v
, pos
, 0);
1090 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1092 "Return the element at the @code{(index1, index2)} element in\n"
1094 #define FUNC_NAME s_scm_array_ref
1099 if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1101 enclosed
= SCM_ENCLOSED_ARRAYP (v
);
1102 pos
= scm_aind (v
, args
, FUNC_NAME
);
1103 v
= SCM_ARRAY_V (v
);
1108 if (SCM_NIMP (args
))
1110 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
1111 pos
= scm_to_long (SCM_CAR (args
));
1112 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1115 pos
= scm_to_long (args
);
1116 length
= scm_c_generalized_vector_length (v
);
1117 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1120 return scm_i_cvref (v
, pos
, enclosed
);
1123 scm_wrong_num_args (NULL
);
1125 scm_out_of_range (NULL
, scm_from_long (pos
));
1130 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1131 (SCM v
, SCM obj
, SCM args
),
1132 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1133 "@var{new-value}. The value returned by array-set! is unspecified.")
1134 #define FUNC_NAME s_scm_array_set_x
1140 pos
= scm_aind (v
, args
, FUNC_NAME
);
1141 v
= SCM_ARRAY_V (v
);
1143 else if (SCM_ENCLOSED_ARRAYP (v
))
1144 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-enclosed array");
1145 else if (scm_is_generalized_vector (v
))
1148 if (scm_is_pair (args
))
1150 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1151 pos
= scm_to_long (SCM_CAR (args
));
1154 pos
= scm_to_long (args
);
1155 length
= scm_c_generalized_vector_length (v
);
1156 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1159 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1161 scm_c_generalized_vector_set_x (v
, pos
, obj
);
1162 return SCM_UNSPECIFIED
;
1165 scm_out_of_range (NULL
, scm_from_long (pos
));
1167 scm_wrong_num_args (NULL
);
1171 /* attempts to unroll an array into a one-dimensional array.
1172 returns the unrolled array or #f if it can't be done. */
1173 /* if strict is not SCM_UNDEFINED, return #f if returned array
1174 wouldn't have contiguous elements. */
1175 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1176 (SCM ra
, SCM strict
),
1177 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1178 "without changing their order (last subscript changing fastest), then\n"
1179 "@code{array-contents} returns that shared array, otherwise it returns\n"
1180 "@code{#f}. All arrays made by @var{make-array} and\n"
1181 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1182 "@var{make-shared-array} may not be.\n\n"
1183 "If the optional argument @var{strict} is provided, a shared array will\n"
1184 "be returned only if its elements are stored internally contiguous in\n"
1186 #define FUNC_NAME s_scm_array_contents
1190 if (scm_is_generalized_vector (ra
))
1193 if (SCM_ARRAYP (ra
))
1195 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1196 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1198 for (k
= 0; k
< ndim
; k
++)
1199 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1200 if (!SCM_UNBNDP (strict
))
1202 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1204 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1206 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1207 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1214 SCM v
= SCM_ARRAY_V (ra
);
1215 size_t length
= scm_c_generalized_vector_length (v
);
1216 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1220 sra
= scm_make_ra (1);
1221 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1222 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1223 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1224 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1225 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1228 else if (SCM_ENCLOSED_ARRAYP (ra
))
1229 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1231 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1237 scm_ra2contig (SCM ra
, int copy
)
1242 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1243 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1244 k
= SCM_ARRAY_NDIM (ra
);
1245 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1247 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1249 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1250 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1251 0 == len
% SCM_LONG_BIT
))
1254 ret
= scm_make_ra (k
);
1255 SCM_ARRAY_BASE (ret
) = 0;
1258 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1259 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1260 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1261 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1263 SCM_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1265 scm_array_copy_x (ra
, ret
);
1271 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1272 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1273 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1274 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1275 "binary objects from @var{port-or-fdes}.\n"
1276 "If an end of file is encountered,\n"
1277 "the objects up to that point are put into @var{ura}\n"
1278 "(starting at the beginning) and the remainder of the array is\n"
1280 "The optional arguments @var{start} and @var{end} allow\n"
1281 "a specified region of a vector (or linearized array) to be read,\n"
1282 "leaving the remainder of the vector unchanged.\n\n"
1283 "@code{uniform-array-read!} returns the number of objects read.\n"
1284 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1285 "returned by @code{(current-input-port)}.")
1286 #define FUNC_NAME s_scm_uniform_array_read_x
1288 if (SCM_UNBNDP (port_or_fd
))
1289 port_or_fd
= scm_cur_inp
;
1291 if (scm_is_uniform_vector (ura
))
1293 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1295 else if (SCM_ARRAYP (ura
))
1297 size_t base
, vlen
, cstart
, cend
;
1300 cra
= scm_ra2contig (ura
, 0);
1301 base
= SCM_ARRAY_BASE (cra
);
1302 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1303 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1307 if (!SCM_UNBNDP (start
))
1309 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1310 if (!SCM_UNBNDP (end
))
1311 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1314 ans
= scm_uniform_vector_read_x (SCM_ARRAY_V (cra
), port_or_fd
,
1315 scm_from_size_t (base
+ cstart
),
1316 scm_from_size_t (base
+ cend
));
1318 if (!scm_is_eq (cra
, ura
))
1319 scm_array_copy_x (cra
, ura
);
1322 else if (SCM_ENCLOSED_ARRAYP (ura
))
1323 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1325 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1329 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1330 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1331 "Writes all elements of @var{ura} as binary objects to\n"
1332 "@var{port-or-fdes}.\n\n"
1333 "The optional arguments @var{start}\n"
1334 "and @var{end} allow\n"
1335 "a specified region of a vector (or linearized array) to be written.\n\n"
1336 "The number of objects actually written is returned.\n"
1337 "@var{port-or-fdes} may be\n"
1338 "omitted, in which case it defaults to the value returned by\n"
1339 "@code{(current-output-port)}.")
1340 #define FUNC_NAME s_scm_uniform_array_write
1342 if (SCM_UNBNDP (port_or_fd
))
1343 port_or_fd
= scm_cur_outp
;
1345 if (scm_is_uniform_vector (ura
))
1347 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1349 else if (SCM_ARRAYP (ura
))
1351 size_t base
, vlen
, cstart
, cend
;
1354 cra
= scm_ra2contig (ura
, 1);
1355 base
= SCM_ARRAY_BASE (cra
);
1356 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1357 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1361 if (!SCM_UNBNDP (start
))
1363 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1364 if (!SCM_UNBNDP (end
))
1365 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1368 ans
= scm_uniform_vector_write (SCM_ARRAY_V (cra
), port_or_fd
,
1369 scm_from_size_t (base
+ cstart
),
1370 scm_from_size_t (base
+ cend
));
1374 else if (SCM_ENCLOSED_ARRAYP (ura
))
1375 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1377 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1384 static scm_t_bits scm_tc16_bitvector
;
1386 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1387 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1388 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1391 bitvector_free (SCM vec
)
1393 scm_gc_free (BITVECTOR_BITS (vec
),
1394 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1400 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1402 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1403 size_t word_len
= (bit_len
+31)/32;
1404 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1407 scm_puts ("#*", port
);
1408 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1410 scm_t_uint32 mask
= 1;
1411 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1412 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1419 bitvector_equalp (SCM vec1
, SCM vec2
)
1421 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1422 size_t word_len
= (bit_len
+ 31) / 32;
1423 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1424 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1425 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1427 /* compare lengths */
1428 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1430 /* avoid underflow in word_len-1 below. */
1433 /* compare full words */
1434 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1436 /* compare partial last words */
1437 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1443 scm_is_bitvector (SCM vec
)
1445 return IS_BITVECTOR (vec
);
1448 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1450 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1451 "return @code{#f}.")
1452 #define FUNC_NAME s_scm_bitvector_p
1454 return scm_from_bool (scm_is_bitvector (obj
));
1459 scm_c_make_bitvector (size_t len
, SCM fill
)
1461 size_t word_len
= (len
+ 31) / 32;
1465 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1467 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1469 if (!SCM_UNBNDP (fill
))
1470 scm_bitvector_fill_x (res
, fill
);
1475 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1476 (SCM len
, SCM fill
),
1477 "Create a new bitvector of length @var{len} and\n"
1478 "optionally initialize all elements to @var{fill}.")
1479 #define FUNC_NAME s_scm_make_bitvector
1481 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1485 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1487 "Create a new bitvector with the arguments as elements.")
1488 #define FUNC_NAME s_scm_bitvector
1490 return scm_list_to_bitvector (bits
);
1495 scm_c_bitvector_length (SCM vec
)
1497 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1498 return BITVECTOR_LENGTH (vec
);
1501 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1503 "Return the length of the bitvector @var{vec}.")
1504 #define FUNC_NAME s_scm_bitvector_length
1506 return scm_from_size_t (scm_c_bitvector_length (vec
));
1510 const scm_t_uint32
*
1511 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1513 return scm_array_handle_bit_writable_elements (h
);
1517 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1520 if (SCM_ARRAYP (vec
))
1521 vec
= SCM_ARRAY_V (vec
);
1522 if (IS_BITVECTOR (vec
))
1523 return BITVECTOR_BITS (vec
) + h
->base
/32;
1524 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1528 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1530 return h
->base
% 32;
1533 const scm_t_uint32
*
1534 scm_bitvector_elements (SCM vec
,
1535 scm_t_array_handle
*h
,
1540 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1545 scm_bitvector_writable_elements (SCM vec
,
1546 scm_t_array_handle
*h
,
1551 scm_generalized_vector_get_handle (vec
, h
);
1554 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1555 *offp
= scm_array_handle_bit_elements_offset (h
);
1556 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1559 return scm_array_handle_bit_writable_elements (h
);
1563 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1565 scm_t_array_handle handle
;
1566 const scm_t_uint32
*bits
;
1568 if (IS_BITVECTOR (vec
))
1570 if (idx
>= BITVECTOR_LENGTH (vec
))
1571 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1572 bits
= BITVECTOR_BITS(vec
);
1573 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1581 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1583 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1584 idx
= idx
*inc
+ off
;
1585 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1586 scm_array_handle_release (&handle
);
1591 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1593 "Return the element at index @var{idx} of the bitvector\n"
1595 #define FUNC_NAME s_scm_bitvector_ref
1597 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1602 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1604 scm_t_array_handle handle
;
1605 scm_t_uint32
*bits
, mask
;
1607 if (IS_BITVECTOR (vec
))
1609 if (idx
>= BITVECTOR_LENGTH (vec
))
1610 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1611 bits
= BITVECTOR_BITS(vec
);
1618 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1620 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1621 idx
= idx
*inc
+ off
;
1624 mask
= 1L << (idx
%32);
1625 if (scm_is_true (val
))
1626 bits
[idx
/32] |= mask
;
1628 bits
[idx
/32] &= ~mask
;
1630 if (!IS_BITVECTOR (vec
))
1631 scm_array_handle_release (&handle
);
1634 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1635 (SCM vec
, SCM idx
, SCM val
),
1636 "Set the element at index @var{idx} of the bitvector\n"
1637 "@var{vec} when @var{val} is true, else clear it.")
1638 #define FUNC_NAME s_scm_bitvector_set_x
1640 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1641 return SCM_UNSPECIFIED
;
1645 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1647 "Set all elements of the bitvector\n"
1648 "@var{vec} when @var{val} is true, else clear them.")
1649 #define FUNC_NAME s_scm_bitvector_fill_x
1651 scm_t_array_handle handle
;
1656 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1659 if (off
== 0 && inc
== 1 && len
> 0)
1663 size_t word_len
= (len
+ 31) / 32;
1664 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1666 if (scm_is_true (val
))
1668 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1669 bits
[word_len
-1] |= last_mask
;
1673 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1674 bits
[word_len
-1] &= ~last_mask
;
1680 for (i
= 0; i
< len
; i
++)
1681 scm_array_handle_set (&handle
, i
, val
);
1684 scm_array_handle_release (&handle
);
1686 return SCM_UNSPECIFIED
;
1690 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1692 "Return a new bitvector initialized with the elements\n"
1694 #define FUNC_NAME s_scm_list_to_bitvector
1696 size_t bit_len
= scm_to_size_t (scm_length (list
));
1697 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1698 size_t word_len
= (bit_len
+31)/32;
1699 scm_t_array_handle handle
;
1700 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1704 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1706 scm_t_uint32 mask
= 1;
1708 for (j
= 0; j
< 32 && j
< bit_len
;
1709 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1710 if (scm_is_true (SCM_CAR (list
)))
1714 scm_array_handle_release (&handle
);
1720 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1722 "Return a new list initialized with the elements\n"
1723 "of the bitvector @var{vec}.")
1724 #define FUNC_NAME s_scm_bitvector_to_list
1726 scm_t_array_handle handle
;
1732 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1735 if (off
== 0 && inc
== 1)
1739 size_t word_len
= (len
+ 31) / 32;
1742 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1744 scm_t_uint32 mask
= 1;
1745 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1746 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1752 for (i
= 0; i
< len
; i
++)
1753 res
= scm_cons (scm_array_handle_ref (&handle
, i
), res
);
1756 scm_array_handle_release (&handle
);
1758 return scm_reverse_x (res
, SCM_EOL
);
1762 /* From mmix-arith.w by Knuth.
1764 Here's a fun way to count the number of bits in a tetrabyte.
1766 [This classical trick is called the ``Gillies--Miller method for
1767 sideways addition'' in {\sl The Preparation of Programs for an
1768 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1769 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1770 the tricks used here were suggested by Balbir Singh, Peter
1771 Rossmanith, and Stefan Schwoon.]
1775 count_ones (scm_t_uint32 x
)
1777 x
=x
-((x
>>1)&0x55555555);
1778 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1779 x
=(x
+(x
>>4))&0x0f0f0f0f;
1781 return (x
+(x
>>16)) & 0xff;
1784 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1785 (SCM b
, SCM bitvector
),
1786 "Return the number of occurrences of the boolean @var{b} in\n"
1788 #define FUNC_NAME s_scm_bit_count
1790 scm_t_array_handle handle
;
1794 int bit
= scm_to_bool (b
);
1797 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1800 if (off
== 0 && inc
== 1 && len
> 0)
1804 size_t word_len
= (len
+ 31) / 32;
1805 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1808 for (i
= 0; i
< word_len
-1; i
++)
1809 count
+= count_ones (bits
[i
]);
1810 count
+= count_ones (bits
[i
] & last_mask
);
1815 for (i
= 0; i
< len
; i
++)
1816 if (scm_is_true (scm_array_handle_ref (&handle
, i
)))
1820 scm_array_handle_release (&handle
);
1822 return scm_from_size_t (bit
? count
: len
-count
);
1826 /* returns 32 for x == 0.
1829 find_first_one (scm_t_uint32 x
)
1832 /* do a binary search in x. */
1833 if ((x
& 0xFFFF) == 0)
1834 x
>>= 16, pos
+= 16;
1835 if ((x
& 0xFF) == 0)
1846 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1847 (SCM item
, SCM v
, SCM k
),
1848 "Return the index of the first occurrance of @var{item} in bit\n"
1849 "vector @var{v}, starting from @var{k}. If there is no\n"
1850 "@var{item} entry between @var{k} and the end of\n"
1851 "@var{bitvector}, then return @code{#f}. For example,\n"
1854 "(bit-position #t #*000101 0) @result{} 3\n"
1855 "(bit-position #f #*0001111 3) @result{} #f\n"
1857 #define FUNC_NAME s_scm_bit_position
1859 scm_t_array_handle handle
;
1860 size_t off
, len
, first_bit
;
1862 const scm_t_uint32
*bits
;
1863 int bit
= scm_to_bool (item
);
1864 SCM res
= SCM_BOOL_F
;
1866 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1867 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1869 if (off
== 0 && inc
== 1 && len
> 0)
1871 size_t i
, word_len
= (len
+ 31) / 32;
1872 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1873 size_t first_word
= first_bit
/ 32;
1874 scm_t_uint32 first_mask
=
1875 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1878 for (i
= first_word
; i
< word_len
; i
++)
1880 w
= (bit
? bits
[i
] : ~bits
[i
]);
1881 if (i
== first_word
)
1883 if (i
== word_len
-1)
1887 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1895 for (i
= first_bit
; i
< len
; i
++)
1897 SCM elt
= scm_array_handle_ref (&handle
, i
);
1898 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1900 res
= scm_from_size_t (i
);
1906 scm_array_handle_release (&handle
);
1912 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1913 (SCM v
, SCM kv
, SCM obj
),
1914 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1915 "selecting the entries to change. The return value is\n"
1918 "If @var{kv} is a bit vector, then those entries where it has\n"
1919 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1920 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1921 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1922 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1925 "(define bv #*01000010)\n"
1926 "(bit-set*! bv #*10010001 #t)\n"
1928 "@result{} #*11010011\n"
1931 "If @var{kv} is a u32vector, then its elements are\n"
1932 "indices into @var{v} which are set to @var{obj}.\n"
1935 "(define bv #*01000010)\n"
1936 "(bit-set*! bv #u32(5 2 7) #t)\n"
1938 "@result{} #*01100111\n"
1940 #define FUNC_NAME s_scm_bit_set_star_x
1942 scm_t_array_handle v_handle
;
1943 size_t v_off
, v_len
;
1945 scm_t_uint32
*v_bits
;
1948 /* Validate that OBJ is a boolean so this is done even if we don't
1951 bit
= scm_to_bool (obj
);
1953 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
1954 &v_off
, &v_len
, &v_inc
);
1956 if (scm_is_bitvector (kv
))
1958 scm_t_array_handle kv_handle
;
1959 size_t kv_off
, kv_len
;
1961 const scm_t_uint32
*kv_bits
;
1963 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
1964 &kv_off
, &kv_len
, &kv_inc
);
1966 if (v_len
!= kv_len
)
1967 scm_misc_error (NULL
,
1968 "bit vectors must have equal length",
1971 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
1973 size_t word_len
= (kv_len
+ 31) / 32;
1974 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
1979 for (i
= 0; i
< word_len
-1; i
++)
1980 v_bits
[i
] &= ~kv_bits
[i
];
1981 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
1985 for (i
= 0; i
< word_len
-1; i
++)
1986 v_bits
[i
] |= kv_bits
[i
];
1987 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
1993 for (i
= 0; i
< kv_len
; i
++)
1994 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
1995 scm_array_handle_set (&v_handle
, i
, obj
);
1998 scm_array_handle_release (&kv_handle
);
2001 else if (scm_is_true (scm_u32vector_p (kv
)))
2003 scm_t_array_handle kv_handle
;
2006 const scm_t_uint32
*kv_elts
;
2008 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2009 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2010 scm_array_handle_set (&v_handle
, (size_t) *kv_elts
, obj
);
2012 scm_array_handle_release (&kv_handle
);
2015 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2017 scm_array_handle_release (&v_handle
);
2019 return SCM_UNSPECIFIED
;
2024 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2025 (SCM v
, SCM kv
, SCM obj
),
2026 "Return a count of how many entries in bit vector @var{v} are\n"
2027 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2030 "If @var{kv} is a bit vector, then those entries where it has\n"
2031 "@code{#t} are the ones in @var{v} which are considered.\n"
2032 "@var{kv} and @var{v} must be the same length.\n"
2034 "If @var{kv} is a u32vector, then it contains\n"
2035 "the indexes in @var{v} to consider.\n"
2040 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2041 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2043 #define FUNC_NAME s_scm_bit_count_star
2045 scm_t_array_handle v_handle
;
2046 size_t v_off
, v_len
;
2048 const scm_t_uint32
*v_bits
;
2052 /* Validate that OBJ is a boolean so this is done even if we don't
2055 bit
= scm_to_bool (obj
);
2057 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2058 &v_off
, &v_len
, &v_inc
);
2060 if (scm_is_bitvector (kv
))
2062 scm_t_array_handle kv_handle
;
2063 size_t kv_off
, kv_len
;
2065 const scm_t_uint32
*kv_bits
;
2067 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2068 &kv_off
, &kv_len
, &kv_inc
);
2070 if (v_len
!= kv_len
)
2071 scm_misc_error (NULL
,
2072 "bit vectors must have equal length",
2075 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2077 size_t i
, word_len
= (kv_len
+ 31) / 32;
2078 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2079 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2081 for (i
= 0; i
< word_len
-1; i
++)
2082 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2083 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2088 for (i
= 0; i
< kv_len
; i
++)
2089 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2091 SCM elt
= scm_array_handle_ref (&v_handle
, i
);
2092 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2097 scm_array_handle_release (&kv_handle
);
2100 else if (scm_is_true (scm_u32vector_p (kv
)))
2102 scm_t_array_handle kv_handle
;
2105 const scm_t_uint32
*kv_elts
;
2107 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2108 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2110 SCM elt
= scm_array_handle_ref (&v_handle
, *kv_elts
);
2111 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2115 scm_array_handle_release (&kv_handle
);
2118 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2120 scm_array_handle_release (&v_handle
);
2122 return scm_from_size_t (count
);
2126 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2128 "Modify the bit vector @var{v} by replacing each element with\n"
2130 #define FUNC_NAME s_scm_bit_invert_x
2132 scm_t_array_handle handle
;
2137 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2139 if (off
== 0 && inc
== 1 && len
> 0)
2141 size_t word_len
= (len
+ 31) / 32;
2142 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2145 for (i
= 0; i
< word_len
-1; i
++)
2147 bits
[i
] = bits
[i
] ^ last_mask
;
2152 for (i
= 0; i
< len
; i
++)
2153 scm_array_handle_set (&handle
, i
,
2154 scm_not (scm_array_handle_ref (&handle
, i
)));
2157 scm_array_handle_release (&handle
);
2159 return SCM_UNSPECIFIED
;
2165 scm_istr2bve (SCM str
)
2167 scm_t_array_handle handle
;
2168 size_t len
= scm_i_string_length (str
);
2169 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2177 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2178 c_str
= scm_i_string_chars (str
);
2180 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2186 for (mask
= 1L; j
--; mask
<<= 1)
2201 scm_array_handle_release (&handle
);
2202 scm_remember_upto_here_1 (str
);
2209 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2214 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
2216 if (k
== SCM_ARRAY_NDIM (ra
))
2217 return scm_i_cvref (SCM_ARRAY_V (ra
), base
, enclosed
);
2219 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2220 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2222 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2226 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2233 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2235 "Return a list consisting of all the elements, in order, of\n"
2237 #define FUNC_NAME s_scm_array_to_list
2239 if (scm_is_generalized_vector (v
))
2240 return scm_generalized_vector_to_list (v
);
2241 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
2242 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2244 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2249 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2251 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2252 (SCM type
, SCM ndim
, SCM lst
),
2253 "Return an array of the type @var{type}\n"
2254 "with elements the same as those of @var{lst}.\n"
2256 "The argument @var{ndim} determines the number of dimensions\n"
2257 "of the array. It is either an exact integer, giving the\n"
2258 "number directly, or a list of exact integers, whose length\n"
2259 "specifies the number of dimensions and each element is the\n"
2260 "lower index bound of its dimension.")
2261 #define FUNC_NAME s_scm_list_to_typed_array
2269 if (scm_is_integer (ndim
))
2271 size_t k
= scm_to_size_t (ndim
);
2274 shape
= scm_cons (scm_length (row
), shape
);
2276 row
= scm_car (row
);
2283 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
2284 scm_sum (scm_sum (scm_car (ndim
),
2286 scm_from_int (-1))),
2288 ndim
= scm_cdr (ndim
);
2289 if (scm_is_pair (ndim
))
2290 row
= scm_car (row
);
2296 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2297 scm_reverse_x (shape
, SCM_EOL
));
2299 if (scm_is_null (shape
))
2301 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2302 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2305 if (!SCM_ARRAYP (ra
))
2307 size_t length
= scm_c_generalized_vector_length (ra
);
2308 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2309 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
2312 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2315 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2320 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2321 (SCM ndim
, SCM lst
),
2322 "Return an array with elements the same as those of @var{lst}.")
2323 #define FUNC_NAME s_scm_list_to_array
2325 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2330 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2332 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2333 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2336 return (scm_is_null (lst
));
2337 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2341 if (!scm_is_pair (lst
))
2343 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2345 lst
= SCM_CDR (lst
);
2347 if (!scm_is_null (lst
))
2354 if (!scm_is_pair (lst
))
2356 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
2358 lst
= SCM_CDR (lst
);
2360 if (!scm_is_null (lst
))
2366 #if SCM_ENABLE_DEPRECATED
2368 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2369 (SCM ndim
, SCM prot
, SCM lst
),
2370 "Return a uniform array of the type indicated by prototype\n"
2371 "@var{prot} with elements the same as those of @var{lst}.\n"
2372 "Elements must be of the appropriate type, no coercions are\n"
2375 "The argument @var{ndim} determines the number of dimensions\n"
2376 "of the array. It is either an exact integer, giving the\n"
2377 "number directly, or a list of exact integers, whose length\n"
2378 "specifies the number of dimensions and each element is the\n"
2379 "lower index bound of its dimension.")
2380 #define FUNC_NAME s_scm_list_to_uniform_array
2382 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2388 /* Print dimension DIM of ARRAY.
2392 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2393 SCM port
, scm_print_state
*pstate
)
2395 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
2398 scm_putc ('(', port
);
2400 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2402 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2403 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2406 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
2408 if (idx
< dim_spec
->ubnd
)
2409 scm_putc (' ', port
);
2410 base
+= dim_spec
->inc
;
2413 scm_putc (')', port
);
2417 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2421 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2423 long ndim
= SCM_ARRAY_NDIM (array
);
2424 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2425 SCM v
= SCM_ARRAY_V (array
);
2426 unsigned long base
= SCM_ARRAY_BASE (array
);
2429 scm_putc ('#', port
);
2430 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2431 scm_intprint (ndim
, 10, port
);
2432 if (scm_is_uniform_vector (v
))
2433 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2434 else if (scm_is_bitvector (v
))
2435 scm_puts ("b", port
);
2436 else if (scm_is_string (v
))
2437 scm_puts ("a", port
);
2438 else if (!scm_is_vector (v
))
2439 scm_puts ("?", port
);
2441 for (i
= 0; i
< ndim
; i
++)
2442 if (dim_specs
[i
].lbnd
!= 0)
2444 for (i
= 0; i
< ndim
; i
++)
2446 scm_putc ('@', port
);
2447 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2454 /* Rank zero arrays, which are really just scalars, are printed
2455 specially. The consequent way would be to print them as
2459 where OBJ is the printed representation of the scalar, but we
2460 print them instead as
2464 to make them look less strange.
2466 Just printing them as
2470 would be correct in a way as well, but zero rank arrays are
2471 not really the same as Scheme values since they are boxed and
2472 can be modified with array-set!, say.
2474 scm_putc ('(', port
);
2475 scm_iprin1 (scm_i_cvref (v
, base
, 0), port
, pstate
);
2476 scm_putc (')', port
);
2480 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2484 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2488 scm_putc ('#', port
);
2489 base
= SCM_ARRAY_BASE (array
);
2490 scm_puts ("<enclosed-array ", port
);
2491 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2492 scm_putc ('>', port
);
2496 /* Read an array. This function can also read vectors and uniform
2497 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2500 C is the first character read after the '#'.
2504 tag_to_type (const char *tag
, SCM port
)
2506 #if SCM_ENABLE_DEPRECATED
2508 /* Recognize the old syntax.
2510 const char *instead
;
2542 if (instead
&& tag
[1] == '\0')
2544 scm_c_issue_deprecation_warning_fmt
2545 ("The tag '%c' is deprecated for uniform vectors. "
2546 "Use '%s' instead.", tag
[0], instead
);
2547 return scm_from_locale_symbol (instead
);
2555 return scm_from_locale_symbol (tag
);
2559 scm_i_read_array (SCM port
, int c
)
2566 SCM lower_bounds
= SCM_BOOL_F
, elements
;
2568 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2569 the array code can not deal with zero-length dimensions yet, and
2570 we want to allow zero-length vectors, of course.
2574 scm_ungetc (c
, port
);
2575 return scm_vector (scm_read (port
));
2578 /* Disambiguate between '#f' and uniform floating point vectors.
2582 c
= scm_getc (port
);
2583 if (c
!= '3' && c
!= '6')
2586 scm_ungetc (c
, port
);
2593 goto continue_reading_tag
;
2599 while ('0' <= c
&& c
<= '9')
2601 rank
= 10*rank
+ c
-'0';
2603 c
= scm_getc (port
);
2610 continue_reading_tag
:
2611 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2614 c
= scm_getc (port
);
2616 tag
[tag_len
] = '\0';
2618 /* Read lower bounds. */
2621 lower_bounds
= SCM_EOL
;
2625 /* Yeah, right, we should use some ready-made integer parsing
2632 c
= scm_getc (port
);
2636 c
= scm_getc (port
);
2638 while ('0' <= c
&& c
<= '9')
2640 lbnd
= 10*lbnd
+ c
-'0';
2641 c
= scm_getc (port
);
2643 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2647 /* Read nested lists of elements.
2650 scm_i_input_error (NULL
, port
,
2651 "missing '(' in vector or array literal",
2653 scm_ungetc (c
, port
);
2654 elements
= scm_read (port
);
2656 if (scm_is_false (lower_bounds
))
2657 lower_bounds
= scm_from_size_t (rank
);
2658 else if (scm_ilength (lower_bounds
) != rank
)
2659 scm_i_input_error (NULL
, port
,
2660 "the number of lower bounds must match the array rank",
2663 /* Handle special print syntax of rank zero arrays; see
2664 scm_i_print_array for a rationale.
2667 elements
= scm_car (elements
);
2671 return scm_list_to_typed_array (tag_to_type (tag
, port
),
2677 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2679 scm_iprin1 (exp
, port
, pstate
);
2683 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2686 #define FUNC_NAME s_scm_array_type
2688 if (SCM_ARRAYP (ra
))
2689 return scm_i_generalized_vector_type (SCM_ARRAY_V (ra
));
2690 else if (scm_is_generalized_vector (ra
))
2691 return scm_i_generalized_vector_type (ra
);
2692 else if (SCM_ENCLOSED_ARRAYP (ra
))
2693 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2695 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2699 #if SCM_ENABLE_DEPRECATED
2701 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2703 "Return an object that would produce an array of the same type\n"
2704 "as @var{array}, if used as the @var{prototype} for\n"
2705 "@code{make-uniform-array}.")
2706 #define FUNC_NAME s_scm_array_prototype
2708 if (SCM_ARRAYP (ra
))
2709 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2710 else if (scm_is_generalized_vector (ra
))
2711 return scm_i_get_old_prototype (ra
);
2712 else if (SCM_ENCLOSED_ARRAYP (ra
))
2713 return SCM_UNSPECIFIED
;
2715 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2722 array_mark (SCM ptr
)
2724 return SCM_ARRAY_V (ptr
);
2728 array_free (SCM ptr
)
2730 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2731 (sizeof (scm_t_array
)
2732 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2740 scm_tc16_array
= scm_make_smob_type ("array", 0);
2741 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2742 scm_set_smob_free (scm_tc16_array
, array_free
);
2743 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2744 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2746 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2747 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2748 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2749 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2750 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2752 scm_add_feature ("array");
2754 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2755 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2756 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2757 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2759 init_type_creator_table ();
2761 #include "libguile/unif.x"