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");
344 scm_generalized_vector_get_handle (SCM vec
, scm_t_array_handle
*h
)
346 scm_array_get_handle (vec
, h
);
347 if (scm_array_handle_rank (h
) != 1)
348 scm_wrong_type_arg_msg (NULL
, 0, vec
, "vector");
352 scm_vector_elements (SCM vec
, scm_t_array_handle
*h
,
353 size_t *lenp
, ssize_t
*incp
)
355 scm_generalized_vector_get_handle (vec
, h
);
358 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
359 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
362 return scm_array_handle_elements (h
);
366 scm_vector_writable_elements (SCM vec
, scm_t_array_handle
*h
,
367 size_t *lenp
, ssize_t
*incp
)
369 scm_generalized_vector_get_handle (vec
, h
);
372 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
373 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
376 return scm_array_handle_writable_elements (h
);
379 #if SCM_ENABLE_DEPRECATED
381 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
383 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
385 #define FUNC_NAME s_scm_array_p
387 if (!SCM_UNBNDP (prot
))
389 scm_c_issue_deprecation_warning
390 ("Using prototypes with `array?' is deprecated."
391 " Use `typed-array?' instead.");
393 return scm_typed_array_p (obj
, prototype_to_type (prot
));
396 return scm_from_bool (scm_is_array (obj
));
400 #else /* !SCM_ENABLE_DEPRECATED */
402 /* We keep the old 2-argument C prototype for a while although the old
403 PROT argument is always ignored now. C code should probably use
404 scm_is_array or scm_is_typed_array anyway.
407 static SCM
scm_i_array_p (SCM obj
);
409 SCM_DEFINE (scm_i_array_p
, "array?", 1, 0, 0,
411 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
413 #define FUNC_NAME s_scm_i_array_p
415 return scm_from_bool (scm_is_array (obj
));
420 scm_array_p (SCM obj
, SCM prot
)
422 return scm_from_bool (scm_is_array (obj
));
425 #endif /* !SCM_ENABLE_DEPRECATED */
428 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
430 "Return @code{#t} if the @var{obj} is an array of type\n"
431 "@var{type}, and @code{#f} if not.")
432 #define FUNC_NAME s_scm_typed_array_p
434 return scm_from_bool (scm_is_typed_array (obj
, type
));
439 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
441 "Return the number of dimensions of the array @var{array.}\n")
442 #define FUNC_NAME s_scm_array_rank
444 if (scm_is_generalized_vector (array
))
445 return scm_from_int (1);
447 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
448 return scm_from_size_t (SCM_ARRAY_NDIM (array
));
450 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
455 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
457 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
458 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
460 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
462 #define FUNC_NAME s_scm_array_dimensions
464 if (scm_is_generalized_vector (ra
))
465 return scm_list_1 (scm_generalized_vector_length (ra
));
467 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
473 k
= SCM_ARRAY_NDIM (ra
);
474 s
= SCM_ARRAY_DIMS (ra
);
476 res
= scm_cons (s
[k
].lbnd
477 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
478 scm_from_long (s
[k
].ubnd
),
480 : scm_from_long (1 + s
[k
].ubnd
),
485 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
490 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
492 "Return the root vector of a shared array.")
493 #define FUNC_NAME s_scm_shared_array_root
495 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
496 SCM_ARG1
, FUNC_NAME
);
497 return SCM_ARRAY_V (ra
);
502 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
504 "Return the root vector index of the first element in the array.")
505 #define FUNC_NAME s_scm_shared_array_offset
507 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
508 SCM_ARG1
, FUNC_NAME
);
509 return scm_from_int (SCM_ARRAY_BASE (ra
));
514 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
516 "For each dimension, return the distance between elements in the root vector.")
517 #define FUNC_NAME s_scm_shared_array_increments
523 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
524 SCM_ARG1
, FUNC_NAME
);
525 k
= SCM_ARRAY_NDIM (ra
);
526 s
= SCM_ARRAY_DIMS (ra
);
528 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
534 static char s_bad_ind
[] = "Bad scm_array index";
538 scm_aind (SCM ra
, SCM args
, const char *what
)
542 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
543 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
544 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
546 if (scm_is_integer (args
))
549 scm_error_num_args_subr (what
);
550 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
552 while (k
&& scm_is_pair (args
))
554 ind
= SCM_CAR (args
);
555 args
= SCM_CDR (args
);
556 if (!scm_is_integer (ind
))
557 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
558 j
= scm_to_long (ind
);
559 if (j
< s
->lbnd
|| j
> s
->ubnd
)
560 scm_out_of_range (what
, ind
);
561 pos
+= (j
- s
->lbnd
) * (s
->inc
);
565 if (k
!= 0 || !scm_is_null (args
))
566 scm_error_num_args_subr (what
);
573 scm_i_make_ra (int ndim
, scm_t_bits tag
)
576 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
577 scm_gc_malloc ((sizeof (scm_t_array
) +
578 ndim
* sizeof (scm_t_array_dim
)),
580 SCM_ARRAY_V (ra
) = SCM_BOOL_F
;
585 scm_make_ra (int ndim
)
587 return scm_i_make_ra (ndim
, scm_tc16_array
);
591 static char s_bad_spec
[] = "Bad scm_array dimension";
594 /* Increments will still need to be set. */
597 scm_shap2ra (SCM args
, const char *what
)
601 int ndim
= scm_ilength (args
);
603 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
605 ra
= scm_make_ra (ndim
);
606 SCM_ARRAY_BASE (ra
) = 0;
607 s
= SCM_ARRAY_DIMS (ra
);
608 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
610 spec
= SCM_CAR (args
);
611 if (scm_is_integer (spec
))
613 if (scm_to_long (spec
) < 0)
614 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
616 s
->ubnd
= scm_to_long (spec
) - 1;
621 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
622 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
623 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
625 if (!scm_is_pair (sp
)
626 || !scm_is_integer (SCM_CAR (sp
))
627 || !scm_is_null (SCM_CDR (sp
)))
628 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
629 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
636 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
637 (SCM type
, SCM fill
, SCM bounds
),
638 "Create and return an array of type @var{type}.")
639 #define FUNC_NAME s_scm_make_typed_array
643 creator_proc
*creator
;
646 creator
= type_to_creator (type
);
647 ra
= scm_shap2ra (bounds
, FUNC_NAME
);
648 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
649 s
= SCM_ARRAY_DIMS (ra
);
650 k
= SCM_ARRAY_NDIM (ra
);
655 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
);
656 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
659 if (scm_is_eq (fill
, SCM_UNSPECIFIED
))
660 fill
= SCM_UNDEFINED
;
662 SCM_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
664 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
665 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
666 return SCM_ARRAY_V (ra
);
671 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
672 (SCM fill
, SCM bounds
),
673 "Create and return an array.")
674 #define FUNC_NAME s_scm_make_array
676 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
680 #if SCM_ENABLE_DEPRECATED
682 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
683 (SCM dims
, SCM prot
, SCM fill
),
684 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
685 "Create and return a uniform array or vector of type\n"
686 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
687 "length @var{length}. If @var{fill} is supplied, it's used to\n"
688 "fill the array, otherwise @var{prototype} is used.")
689 #define FUNC_NAME s_scm_dimensions_to_uniform_array
691 scm_c_issue_deprecation_warning
692 ("`dimensions->uniform-array' is deprecated. "
693 "Use `make-typed-array' instead.");
695 if (scm_is_integer (dims
))
696 dims
= scm_list_1 (dims
);
697 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
704 scm_ra_set_contp (SCM ra
)
706 /* XXX - correct? one-dimensional arrays are always 'contiguous',
709 size_t k
= SCM_ARRAY_NDIM (ra
);
712 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
715 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
717 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
720 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
721 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
724 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
728 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
729 (SCM oldra
, SCM mapfunc
, SCM dims
),
730 "@code{make-shared-array} can be used to create shared subarrays of other\n"
731 "arrays. The @var{mapper} is a function that translates coordinates in\n"
732 "the new array into coordinates in the old array. A @var{mapper} must be\n"
733 "linear, and its range must stay within the bounds of the old array, but\n"
734 "it can be otherwise arbitrary. A simple example:\n"
736 "(define fred (make-array #f 8 8))\n"
737 "(define freds-diagonal\n"
738 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
739 "(array-set! freds-diagonal 'foo 3)\n"
740 "(array-ref fred 3 3) @result{} foo\n"
741 "(define freds-center\n"
742 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
743 "(array-ref freds-center 0 0) @result{} foo\n"
745 #define FUNC_NAME s_scm_make_shared_array
751 long old_min
, new_min
, old_max
, new_max
;
754 SCM_VALIDATE_REST_ARGUMENT (dims
);
755 SCM_VALIDATE_ARRAY (1, oldra
);
756 SCM_VALIDATE_PROC (2, mapfunc
);
757 ra
= scm_shap2ra (dims
, FUNC_NAME
);
758 if (SCM_ARRAYP (oldra
))
760 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
761 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
762 s
= SCM_ARRAY_DIMS (oldra
);
763 k
= SCM_ARRAY_NDIM (oldra
);
767 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
769 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
774 SCM_ARRAY_V (ra
) = oldra
;
776 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
779 s
= SCM_ARRAY_DIMS (ra
);
780 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
782 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
783 if (s
[k
].ubnd
< s
[k
].lbnd
)
785 if (1 == SCM_ARRAY_NDIM (ra
))
786 ra
= make_typed_vector (scm_array_type (ra
), 0);
788 SCM_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
792 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
793 if (SCM_ARRAYP (oldra
))
794 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
797 if (!scm_is_integer (imap
))
799 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
800 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
801 imap
= SCM_CAR (imap
);
803 i
= scm_to_size_t (imap
);
805 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
807 k
= SCM_ARRAY_NDIM (ra
);
810 if (s
[k
].ubnd
> s
[k
].lbnd
)
812 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
813 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
814 if (SCM_ARRAYP (oldra
))
816 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
819 if (!scm_is_integer (imap
))
821 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
822 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
823 imap
= SCM_CAR (imap
);
825 s
[k
].inc
= scm_to_long (imap
) - i
;
829 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
831 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
834 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
835 indptr
= SCM_CDR (indptr
);
837 if (old_min
> new_min
|| old_max
< new_max
)
838 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
839 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
841 SCM v
= SCM_ARRAY_V (ra
);
842 size_t length
= scm_c_generalized_vector_length (v
);
843 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
845 if (s
->ubnd
< s
->lbnd
)
846 return make_typed_vector (scm_array_type (ra
), 0);
848 scm_ra_set_contp (ra
);
854 /* args are RA . DIMS */
855 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
857 "Return an array sharing contents with @var{array}, but with\n"
858 "dimensions arranged in a different order. There must be one\n"
859 "@var{dim} argument for each dimension of @var{array}.\n"
860 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
861 "and the rank of the array to be returned. Each integer in that\n"
862 "range must appear at least once in the argument list.\n"
864 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
865 "dimensions in the array to be returned, their positions in the\n"
866 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
867 "may have the same value, in which case the returned array will\n"
868 "have smaller rank than @var{array}.\n"
871 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
872 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
873 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
874 " #2((a 4) (b 5) (c 6))\n"
876 #define FUNC_NAME s_scm_transpose_array
879 scm_t_array_dim
*s
, *r
;
882 SCM_VALIDATE_REST_ARGUMENT (args
);
883 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
885 if (scm_is_generalized_vector (ra
))
887 /* Make sure that we are called with a single zero as
890 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
891 SCM_WRONG_NUM_ARGS ();
892 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
893 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
897 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
899 vargs
= scm_vector (args
);
900 if (SCM_SIMPLE_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
901 SCM_WRONG_NUM_ARGS ();
903 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
905 i
= scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs
, k
),
906 0, SCM_ARRAY_NDIM(ra
));
911 res
= scm_make_ra (ndim
);
912 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
913 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
916 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
917 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
919 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
921 i
= scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs
, k
));
922 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
923 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
924 if (r
->ubnd
< r
->lbnd
)
933 if (r
->ubnd
> s
->ubnd
)
935 if (r
->lbnd
< s
->lbnd
)
937 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
944 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
945 scm_ra_set_contp (res
);
949 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
953 /* args are RA . AXES */
954 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
956 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
957 "the rank of @var{array}. @var{enclose-array} returns an array\n"
958 "resembling an array of shared arrays. The dimensions of each shared\n"
959 "array are the same as the @var{dim}th dimensions of the original array,\n"
960 "the dimensions of the outer array are the same as those of the original\n"
961 "array that did not match a @var{dim}.\n\n"
962 "An enclosed array is not a general Scheme array. Its elements may not\n"
963 "be set using @code{array-set!}. Two references to the same element of\n"
964 "an enclosed array will be @code{equal?} but will not in general be\n"
965 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
966 "enclosed array is unspecified.\n\n"
969 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
970 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
971 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
972 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
974 #define FUNC_NAME s_scm_enclose_array
976 SCM axv
, res
, ra_inr
;
978 scm_t_array_dim vdim
, *s
= &vdim
;
979 int ndim
, j
, k
, ninr
, noutr
;
981 SCM_VALIDATE_REST_ARGUMENT (axes
);
982 if (scm_is_null (axes
))
983 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
984 ninr
= scm_ilength (axes
);
986 SCM_WRONG_NUM_ARGS ();
987 ra_inr
= scm_make_ra (ninr
);
989 if (scm_is_generalized_vector (ra
))
992 s
->ubnd
= scm_c_generalized_vector_length (ra
) - 1;
994 SCM_ARRAY_V (ra_inr
) = ra
;
995 SCM_ARRAY_BASE (ra_inr
) = 0;
998 else if (SCM_ARRAYP (ra
))
1000 s
= SCM_ARRAY_DIMS (ra
);
1001 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
1002 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
1003 ndim
= SCM_ARRAY_NDIM (ra
);
1006 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1008 noutr
= ndim
- ninr
;
1010 SCM_WRONG_NUM_ARGS ();
1011 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
1012 res
= scm_i_make_ra (noutr
, scm_tc16_enclosed_array
);
1013 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
1014 SCM_ARRAY_V (res
) = ra_inr
;
1015 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
1017 if (!scm_is_integer (SCM_CAR (axes
)))
1018 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
1019 j
= scm_to_int (SCM_CAR (axes
));
1020 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
1021 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
1022 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
1023 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
1025 c_axv
= scm_i_string_chars (axv
);
1026 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
1030 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
1031 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
1032 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
1034 scm_remember_upto_here_1 (axv
);
1035 scm_ra_set_contp (ra_inr
);
1036 scm_ra_set_contp (res
);
1043 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1045 "Return @code{#t} if its arguments would be acceptable to\n"
1046 "@code{array-ref}.")
1047 #define FUNC_NAME s_scm_array_in_bounds_p
1049 SCM res
= SCM_BOOL_T
;
1051 SCM_VALIDATE_REST_ARGUMENT (args
);
1053 if (scm_is_generalized_vector (v
))
1057 if (!scm_is_pair (args
))
1058 SCM_WRONG_NUM_ARGS ();
1059 ind
= scm_to_long (SCM_CAR (args
));
1060 args
= SCM_CDR (args
);
1061 res
= scm_from_bool (ind
>= 0
1062 && ind
< scm_c_generalized_vector_length (v
));
1064 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1066 size_t k
= SCM_ARRAY_NDIM (v
);
1067 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (v
);
1073 if (!scm_is_pair (args
))
1074 SCM_WRONG_NUM_ARGS ();
1075 ind
= scm_to_long (SCM_CAR (args
));
1076 args
= SCM_CDR (args
);
1079 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
1082 /* We do not stop the checking after finding a violation
1083 since we want to validate the type-correctness and
1084 number of arguments in any case.
1090 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1092 if (!scm_is_null (args
))
1093 SCM_WRONG_NUM_ARGS ();
1100 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
1104 int k
= SCM_ARRAY_NDIM (v
);
1105 SCM res
= scm_make_ra (k
);
1106 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1107 SCM_ARRAY_BASE (res
) = pos
;
1110 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1111 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1112 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1117 return scm_c_generalized_vector_ref (v
, pos
);
1121 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1123 return scm_i_cvref (v
, pos
, 0);
1126 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
1128 "Return the element at the @code{(index1, index2)} element in\n"
1130 #define FUNC_NAME s_scm_array_ref
1135 if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1137 enclosed
= SCM_ENCLOSED_ARRAYP (v
);
1138 pos
= scm_aind (v
, args
, FUNC_NAME
);
1139 v
= SCM_ARRAY_V (v
);
1144 if (SCM_NIMP (args
))
1146 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
1147 pos
= scm_to_long (SCM_CAR (args
));
1148 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1151 pos
= scm_to_long (args
);
1152 length
= scm_c_generalized_vector_length (v
);
1153 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1156 return scm_i_cvref (v
, pos
, enclosed
);
1159 scm_wrong_num_args (NULL
);
1161 scm_out_of_range (NULL
, scm_from_long (pos
));
1166 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1167 (SCM v
, SCM obj
, SCM args
),
1168 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1169 "@var{new-value}. The value returned by array-set! is unspecified.")
1170 #define FUNC_NAME s_scm_array_set_x
1176 pos
= scm_aind (v
, args
, FUNC_NAME
);
1177 v
= SCM_ARRAY_V (v
);
1179 else if (SCM_ENCLOSED_ARRAYP (v
))
1180 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-enclosed array");
1181 else if (scm_is_generalized_vector (v
))
1184 if (scm_is_pair (args
))
1186 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1187 pos
= scm_to_long (SCM_CAR (args
));
1190 pos
= scm_to_long (args
);
1191 length
= scm_c_generalized_vector_length (v
);
1192 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1195 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1197 scm_c_generalized_vector_set_x (v
, pos
, obj
);
1198 return SCM_UNSPECIFIED
;
1201 scm_out_of_range (NULL
, scm_from_long (pos
));
1203 scm_wrong_num_args (NULL
);
1207 /* attempts to unroll an array into a one-dimensional array.
1208 returns the unrolled array or #f if it can't be done. */
1209 /* if strict is not SCM_UNDEFINED, return #f if returned array
1210 wouldn't have contiguous elements. */
1211 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1212 (SCM ra
, SCM strict
),
1213 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1214 "without changing their order (last subscript changing fastest), then\n"
1215 "@code{array-contents} returns that shared array, otherwise it returns\n"
1216 "@code{#f}. All arrays made by @var{make-array} and\n"
1217 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1218 "@var{make-shared-array} may not be.\n\n"
1219 "If the optional argument @var{strict} is provided, a shared array will\n"
1220 "be returned only if its elements are stored internally contiguous in\n"
1222 #define FUNC_NAME s_scm_array_contents
1226 if (scm_is_generalized_vector (ra
))
1229 if (SCM_ARRAYP (ra
))
1231 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1232 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1234 for (k
= 0; k
< ndim
; k
++)
1235 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1236 if (!SCM_UNBNDP (strict
))
1238 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1240 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1242 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1243 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1250 SCM v
= SCM_ARRAY_V (ra
);
1251 size_t length
= scm_c_generalized_vector_length (v
);
1252 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1256 sra
= scm_make_ra (1);
1257 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1258 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1259 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1260 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1261 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1264 else if (SCM_ENCLOSED_ARRAYP (ra
))
1265 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1267 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1273 scm_ra2contig (SCM ra
, int copy
)
1278 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1279 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1280 k
= SCM_ARRAY_NDIM (ra
);
1281 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1283 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1285 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1286 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1287 0 == len
% SCM_LONG_BIT
))
1290 ret
= scm_make_ra (k
);
1291 SCM_ARRAY_BASE (ret
) = 0;
1294 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1295 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1296 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1297 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1299 SCM_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1301 scm_array_copy_x (ra
, ret
);
1307 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1308 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1309 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1310 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1311 "binary objects from @var{port-or-fdes}.\n"
1312 "If an end of file is encountered,\n"
1313 "the objects up to that point are put into @var{ura}\n"
1314 "(starting at the beginning) and the remainder of the array is\n"
1316 "The optional arguments @var{start} and @var{end} allow\n"
1317 "a specified region of a vector (or linearized array) to be read,\n"
1318 "leaving the remainder of the vector unchanged.\n\n"
1319 "@code{uniform-array-read!} returns the number of objects read.\n"
1320 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1321 "returned by @code{(current-input-port)}.")
1322 #define FUNC_NAME s_scm_uniform_array_read_x
1324 if (SCM_UNBNDP (port_or_fd
))
1325 port_or_fd
= scm_cur_inp
;
1327 if (scm_is_uniform_vector (ura
))
1329 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1331 else if (SCM_ARRAYP (ura
))
1333 size_t base
, vlen
, cstart
, cend
;
1336 cra
= scm_ra2contig (ura
, 0);
1337 base
= SCM_ARRAY_BASE (cra
);
1338 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1339 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1343 if (!SCM_UNBNDP (start
))
1345 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1346 if (!SCM_UNBNDP (end
))
1347 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1350 ans
= scm_uniform_vector_read_x (SCM_ARRAY_V (cra
), port_or_fd
,
1351 scm_from_size_t (base
+ cstart
),
1352 scm_from_size_t (base
+ cend
));
1354 if (!scm_is_eq (cra
, ura
))
1355 scm_array_copy_x (cra
, ura
);
1358 else if (SCM_ENCLOSED_ARRAYP (ura
))
1359 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1361 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1365 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1366 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1367 "Writes all elements of @var{ura} as binary objects to\n"
1368 "@var{port-or-fdes}.\n\n"
1369 "The optional arguments @var{start}\n"
1370 "and @var{end} allow\n"
1371 "a specified region of a vector (or linearized array) to be written.\n\n"
1372 "The number of objects actually written is returned.\n"
1373 "@var{port-or-fdes} may be\n"
1374 "omitted, in which case it defaults to the value returned by\n"
1375 "@code{(current-output-port)}.")
1376 #define FUNC_NAME s_scm_uniform_array_write
1378 if (SCM_UNBNDP (port_or_fd
))
1379 port_or_fd
= scm_cur_outp
;
1381 if (scm_is_uniform_vector (ura
))
1383 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1385 else if (SCM_ARRAYP (ura
))
1387 size_t base
, vlen
, cstart
, cend
;
1390 cra
= scm_ra2contig (ura
, 1);
1391 base
= SCM_ARRAY_BASE (cra
);
1392 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1393 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1397 if (!SCM_UNBNDP (start
))
1399 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1400 if (!SCM_UNBNDP (end
))
1401 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1404 ans
= scm_uniform_vector_write (SCM_ARRAY_V (cra
), port_or_fd
,
1405 scm_from_size_t (base
+ cstart
),
1406 scm_from_size_t (base
+ cend
));
1410 else if (SCM_ENCLOSED_ARRAYP (ura
))
1411 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1413 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1420 static scm_t_bits scm_tc16_bitvector
;
1422 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1423 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1424 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1427 bitvector_free (SCM vec
)
1429 scm_gc_free (BITVECTOR_BITS (vec
),
1430 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1436 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1438 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1439 size_t word_len
= (bit_len
+31)/32;
1440 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1443 scm_puts ("#*", port
);
1444 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1446 scm_t_uint32 mask
= 1;
1447 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1448 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1455 bitvector_equalp (SCM vec1
, SCM vec2
)
1457 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1458 size_t word_len
= (bit_len
+ 31) / 32;
1459 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1460 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1461 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1463 /* compare lengths */
1464 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1466 /* avoid underflow in word_len-1 below. */
1469 /* compare full words */
1470 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1472 /* compare partial last words */
1473 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1479 scm_is_bitvector (SCM vec
)
1481 return IS_BITVECTOR (vec
);
1484 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1486 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1487 "return @code{#f}.")
1488 #define FUNC_NAME s_scm_bitvector_p
1490 return scm_from_bool (scm_is_bitvector (obj
));
1495 scm_c_make_bitvector (size_t len
, SCM fill
)
1497 size_t word_len
= (len
+ 31) / 32;
1501 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1503 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1505 if (!SCM_UNBNDP (fill
))
1506 scm_bitvector_fill_x (res
, fill
);
1511 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1512 (SCM len
, SCM fill
),
1513 "Create a new bitvector of length @var{len} and\n"
1514 "optionally initialize all elements to @var{fill}.")
1515 #define FUNC_NAME s_scm_make_bitvector
1517 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1521 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1523 "Create a new bitvector with the arguments as elements.")
1524 #define FUNC_NAME s_scm_bitvector
1526 return scm_list_to_bitvector (bits
);
1531 scm_c_bitvector_length (SCM vec
)
1533 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1534 return BITVECTOR_LENGTH (vec
);
1537 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1539 "Return the length of the bitvector @var{vec}.")
1540 #define FUNC_NAME s_scm_bitvector_length
1542 return scm_from_size_t (scm_c_bitvector_length (vec
));
1546 const scm_t_uint32
*
1547 scm_array_handle_bit_elements (scm_t_array_handle
*h
)
1549 return scm_array_handle_bit_writable_elements (h
);
1553 scm_array_handle_bit_writable_elements (scm_t_array_handle
*h
)
1556 if (SCM_ARRAYP (vec
))
1557 vec
= SCM_ARRAY_V (vec
);
1558 if (IS_BITVECTOR (vec
))
1559 return BITVECTOR_BITS (vec
) + h
->base
/32;
1560 scm_wrong_type_arg_msg (NULL
, 0, h
->array
, "bit array");
1564 scm_array_handle_bit_elements_offset (scm_t_array_handle
*h
)
1566 return h
->base
% 32;
1569 const scm_t_uint32
*
1570 scm_bitvector_elements (SCM vec
,
1571 scm_t_array_handle
*h
,
1576 return scm_bitvector_writable_elements (vec
, h
, offp
, lenp
, incp
);
1581 scm_bitvector_writable_elements (SCM vec
,
1582 scm_t_array_handle
*h
,
1587 scm_generalized_vector_get_handle (vec
, h
);
1590 scm_t_array_dim
*dim
= scm_array_handle_dims (h
);
1591 *offp
= scm_array_handle_bit_elements_offset (h
);
1592 *lenp
= dim
->ubnd
- dim
->lbnd
+ 1;
1595 return scm_array_handle_bit_writable_elements (h
);
1599 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1601 scm_t_array_handle handle
;
1602 const scm_t_uint32
*bits
;
1604 if (IS_BITVECTOR (vec
))
1606 if (idx
>= BITVECTOR_LENGTH (vec
))
1607 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1608 bits
= BITVECTOR_BITS(vec
);
1609 return scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1617 bits
= scm_bitvector_elements (vec
, &handle
, &off
, &len
, &inc
);
1619 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1620 idx
= idx
*inc
+ off
;
1621 res
= scm_from_bool (bits
[idx
/32] & (1L << (idx
%32)));
1622 scm_array_handle_release (&handle
);
1627 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1629 "Return the element at index @var{idx} of the bitvector\n"
1631 #define FUNC_NAME s_scm_bitvector_ref
1633 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1638 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1640 scm_t_array_handle handle
;
1641 scm_t_uint32
*bits
, mask
;
1643 if (IS_BITVECTOR (vec
))
1645 if (idx
>= BITVECTOR_LENGTH (vec
))
1646 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1647 bits
= BITVECTOR_BITS(vec
);
1654 bits
= scm_bitvector_writable_elements (vec
, &handle
, &off
, &len
, &inc
);
1656 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1657 idx
= idx
*inc
+ off
;
1660 mask
= 1L << (idx
%32);
1661 if (scm_is_true (val
))
1662 bits
[idx
/32] |= mask
;
1664 bits
[idx
/32] &= ~mask
;
1666 if (!IS_BITVECTOR (vec
))
1667 scm_array_handle_release (&handle
);
1670 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1671 (SCM vec
, SCM idx
, SCM val
),
1672 "Set the element at index @var{idx} of the bitvector\n"
1673 "@var{vec} when @var{val} is true, else clear it.")
1674 #define FUNC_NAME s_scm_bitvector_set_x
1676 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1677 return SCM_UNSPECIFIED
;
1681 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1683 "Set all elements of the bitvector\n"
1684 "@var{vec} when @var{val} is true, else clear them.")
1685 #define FUNC_NAME s_scm_bitvector_fill_x
1687 scm_t_array_handle handle
;
1692 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1695 if (off
== 0 && inc
== 1 && len
> 0)
1699 size_t word_len
= (len
+ 31) / 32;
1700 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1702 if (scm_is_true (val
))
1704 memset (bits
, 0xFF, sizeof(scm_t_uint32
)*(word_len
-1));
1705 bits
[word_len
-1] |= last_mask
;
1709 memset (bits
, 0x00, sizeof(scm_t_uint32
)*(word_len
-1));
1710 bits
[word_len
-1] &= ~last_mask
;
1716 for (i
= 0; i
< len
; i
++)
1717 scm_array_handle_set (&handle
, i
, val
);
1720 scm_array_handle_release (&handle
);
1722 return SCM_UNSPECIFIED
;
1726 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1728 "Return a new bitvector initialized with the elements\n"
1730 #define FUNC_NAME s_scm_list_to_bitvector
1732 size_t bit_len
= scm_to_size_t (scm_length (list
));
1733 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1734 size_t word_len
= (bit_len
+31)/32;
1735 scm_t_array_handle handle
;
1736 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
, &handle
,
1740 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1742 scm_t_uint32 mask
= 1;
1744 for (j
= 0; j
< 32 && j
< bit_len
;
1745 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1746 if (scm_is_true (SCM_CAR (list
)))
1750 scm_array_handle_release (&handle
);
1756 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1758 "Return a new list initialized with the elements\n"
1759 "of the bitvector @var{vec}.")
1760 #define FUNC_NAME s_scm_bitvector_to_list
1762 scm_t_array_handle handle
;
1768 bits
= scm_bitvector_writable_elements (vec
, &handle
,
1771 if (off
== 0 && inc
== 1)
1775 size_t word_len
= (len
+ 31) / 32;
1778 for (i
= 0; i
< word_len
; i
++, len
-= 32)
1780 scm_t_uint32 mask
= 1;
1781 for (j
= 0; j
< 32 && j
< len
; j
++, mask
<<= 1)
1782 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1788 for (i
= 0; i
< len
; i
++)
1789 res
= scm_cons (scm_array_handle_ref (&handle
, i
), res
);
1792 scm_array_handle_release (&handle
);
1794 return scm_reverse_x (res
, SCM_EOL
);
1798 /* From mmix-arith.w by Knuth.
1800 Here's a fun way to count the number of bits in a tetrabyte.
1802 [This classical trick is called the ``Gillies--Miller method for
1803 sideways addition'' in {\sl The Preparation of Programs for an
1804 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1805 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1806 the tricks used here were suggested by Balbir Singh, Peter
1807 Rossmanith, and Stefan Schwoon.]
1811 count_ones (scm_t_uint32 x
)
1813 x
=x
-((x
>>1)&0x55555555);
1814 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1815 x
=(x
+(x
>>4))&0x0f0f0f0f;
1817 return (x
+(x
>>16)) & 0xff;
1820 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1821 (SCM b
, SCM bitvector
),
1822 "Return the number of occurrences of the boolean @var{b} in\n"
1824 #define FUNC_NAME s_scm_bit_count
1826 scm_t_array_handle handle
;
1830 int bit
= scm_to_bool (b
);
1833 bits
= scm_bitvector_writable_elements (bitvector
, &handle
,
1836 if (off
== 0 && inc
== 1 && len
> 0)
1840 size_t word_len
= (len
+ 31) / 32;
1841 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1844 for (i
= 0; i
< word_len
-1; i
++)
1845 count
+= count_ones (bits
[i
]);
1846 count
+= count_ones (bits
[i
] & last_mask
);
1851 for (i
= 0; i
< len
; i
++)
1852 if (scm_is_true (scm_array_handle_ref (&handle
, i
)))
1856 scm_array_handle_release (&handle
);
1858 return scm_from_size_t (bit
? count
: len
-count
);
1862 /* returns 32 for x == 0.
1865 find_first_one (scm_t_uint32 x
)
1868 /* do a binary search in x. */
1869 if ((x
& 0xFFFF) == 0)
1870 x
>>= 16, pos
+= 16;
1871 if ((x
& 0xFF) == 0)
1882 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1883 (SCM item
, SCM v
, SCM k
),
1884 "Return the index of the first occurrance of @var{item} in bit\n"
1885 "vector @var{v}, starting from @var{k}. If there is no\n"
1886 "@var{item} entry between @var{k} and the end of\n"
1887 "@var{bitvector}, then return @code{#f}. For example,\n"
1890 "(bit-position #t #*000101 0) @result{} 3\n"
1891 "(bit-position #f #*0001111 3) @result{} #f\n"
1893 #define FUNC_NAME s_scm_bit_position
1895 scm_t_array_handle handle
;
1896 size_t off
, len
, first_bit
;
1898 const scm_t_uint32
*bits
;
1899 int bit
= scm_to_bool (item
);
1900 SCM res
= SCM_BOOL_F
;
1902 bits
= scm_bitvector_elements (v
, &handle
, &off
, &len
, &inc
);
1903 first_bit
= scm_to_unsigned_integer (k
, 0, len
);
1905 if (off
== 0 && inc
== 1 && len
> 0)
1907 size_t i
, word_len
= (len
+ 31) / 32;
1908 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
1909 size_t first_word
= first_bit
/ 32;
1910 scm_t_uint32 first_mask
=
1911 ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1914 for (i
= first_word
; i
< word_len
; i
++)
1916 w
= (bit
? bits
[i
] : ~bits
[i
]);
1917 if (i
== first_word
)
1919 if (i
== word_len
-1)
1923 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1931 for (i
= first_bit
; i
< len
; i
++)
1933 SCM elt
= scm_array_handle_ref (&handle
, i
);
1934 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
1936 res
= scm_from_size_t (i
);
1942 scm_array_handle_release (&handle
);
1948 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1949 (SCM v
, SCM kv
, SCM obj
),
1950 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1951 "selecting the entries to change. The return value is\n"
1954 "If @var{kv} is a bit vector, then those entries where it has\n"
1955 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1956 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1957 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1958 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1961 "(define bv #*01000010)\n"
1962 "(bit-set*! bv #*10010001 #t)\n"
1964 "@result{} #*11010011\n"
1967 "If @var{kv} is a u32vector, then its elements are\n"
1968 "indices into @var{v} which are set to @var{obj}.\n"
1971 "(define bv #*01000010)\n"
1972 "(bit-set*! bv #u32(5 2 7) #t)\n"
1974 "@result{} #*01100111\n"
1976 #define FUNC_NAME s_scm_bit_set_star_x
1978 scm_t_array_handle v_handle
;
1979 size_t v_off
, v_len
;
1981 scm_t_uint32
*v_bits
;
1984 /* Validate that OBJ is a boolean so this is done even if we don't
1987 bit
= scm_to_bool (obj
);
1989 v_bits
= scm_bitvector_writable_elements (v
, &v_handle
,
1990 &v_off
, &v_len
, &v_inc
);
1992 if (scm_is_bitvector (kv
))
1994 scm_t_array_handle kv_handle
;
1995 size_t kv_off
, kv_len
;
1997 const scm_t_uint32
*kv_bits
;
1999 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2000 &kv_off
, &kv_len
, &kv_inc
);
2002 if (v_len
!= kv_len
)
2003 scm_misc_error (NULL
,
2004 "bit vectors must have equal length",
2007 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2009 size_t word_len
= (kv_len
+ 31) / 32;
2010 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2015 for (i
= 0; i
< word_len
-1; i
++)
2016 v_bits
[i
] &= ~kv_bits
[i
];
2017 v_bits
[i
] &= ~(kv_bits
[i
] & last_mask
);
2021 for (i
= 0; i
< word_len
-1; i
++)
2022 v_bits
[i
] |= kv_bits
[i
];
2023 v_bits
[i
] |= kv_bits
[i
] & last_mask
;
2029 for (i
= 0; i
< kv_len
; i
++)
2030 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2031 scm_array_handle_set (&v_handle
, i
, obj
);
2034 scm_array_handle_release (&kv_handle
);
2037 else if (scm_is_true (scm_u32vector_p (kv
)))
2039 scm_t_array_handle kv_handle
;
2042 const scm_t_uint32
*kv_elts
;
2044 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2045 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2046 scm_array_handle_set (&v_handle
, (size_t) *kv_elts
, obj
);
2048 scm_array_handle_release (&kv_handle
);
2051 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2053 scm_array_handle_release (&v_handle
);
2055 return SCM_UNSPECIFIED
;
2060 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
2061 (SCM v
, SCM kv
, SCM obj
),
2062 "Return a count of how many entries in bit vector @var{v} are\n"
2063 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
2066 "If @var{kv} is a bit vector, then those entries where it has\n"
2067 "@code{#t} are the ones in @var{v} which are considered.\n"
2068 "@var{kv} and @var{v} must be the same length.\n"
2070 "If @var{kv} is a u32vector, then it contains\n"
2071 "the indexes in @var{v} to consider.\n"
2076 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
2077 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
2079 #define FUNC_NAME s_scm_bit_count_star
2081 scm_t_array_handle v_handle
;
2082 size_t v_off
, v_len
;
2084 const scm_t_uint32
*v_bits
;
2088 /* Validate that OBJ is a boolean so this is done even if we don't
2091 bit
= scm_to_bool (obj
);
2093 v_bits
= scm_bitvector_elements (v
, &v_handle
,
2094 &v_off
, &v_len
, &v_inc
);
2096 if (scm_is_bitvector (kv
))
2098 scm_t_array_handle kv_handle
;
2099 size_t kv_off
, kv_len
;
2101 const scm_t_uint32
*kv_bits
;
2103 kv_bits
= scm_bitvector_elements (v
, &kv_handle
,
2104 &kv_off
, &kv_len
, &kv_inc
);
2106 if (v_len
!= kv_len
)
2107 scm_misc_error (NULL
,
2108 "bit vectors must have equal length",
2111 if (v_off
== 0 && v_inc
== 1 && kv_off
== 0 && kv_inc
== 1 && kv_len
> 0)
2113 size_t i
, word_len
= (kv_len
+ 31) / 32;
2114 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- kv_len
);
2115 scm_t_uint32 xor_mask
= bit
? 0 : ((scm_t_uint32
)-1);
2117 for (i
= 0; i
< word_len
-1; i
++)
2118 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
]);
2119 count
+= count_ones ((v_bits
[i
]^xor_mask
) & kv_bits
[i
] & last_mask
);
2124 for (i
= 0; i
< kv_len
; i
++)
2125 if (scm_is_true (scm_array_handle_ref (&kv_handle
, i
)))
2127 SCM elt
= scm_array_handle_ref (&v_handle
, i
);
2128 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2133 scm_array_handle_release (&kv_handle
);
2136 else if (scm_is_true (scm_u32vector_p (kv
)))
2138 scm_t_array_handle kv_handle
;
2141 const scm_t_uint32
*kv_elts
;
2143 kv_elts
= scm_u32vector_elements (kv
, &kv_handle
, &kv_len
, &kv_inc
);
2144 for (i
= 0; i
< kv_len
; i
++, kv_elts
+= kv_inc
)
2146 SCM elt
= scm_array_handle_ref (&v_handle
, *kv_elts
);
2147 if ((bit
&& scm_is_true (elt
)) || (!bit
&& scm_is_false (elt
)))
2151 scm_array_handle_release (&kv_handle
);
2154 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
2156 scm_array_handle_release (&v_handle
);
2158 return scm_from_size_t (count
);
2162 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2164 "Modify the bit vector @var{v} by replacing each element with\n"
2166 #define FUNC_NAME s_scm_bit_invert_x
2168 scm_t_array_handle handle
;
2173 bits
= scm_bitvector_writable_elements (v
, &handle
, &off
, &len
, &inc
);
2175 if (off
== 0 && inc
== 1 && len
> 0)
2177 size_t word_len
= (len
+ 31) / 32;
2178 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- len
);
2181 for (i
= 0; i
< word_len
-1; i
++)
2183 bits
[i
] = bits
[i
] ^ last_mask
;
2188 for (i
= 0; i
< len
; i
++)
2189 scm_array_handle_set (&handle
, i
,
2190 scm_not (scm_array_handle_ref (&handle
, i
)));
2193 scm_array_handle_release (&handle
);
2195 return SCM_UNSPECIFIED
;
2201 scm_istr2bve (SCM str
)
2203 scm_t_array_handle handle
;
2204 size_t len
= scm_i_string_length (str
);
2205 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
2213 data
= scm_bitvector_writable_elements (vec
, &handle
, NULL
, NULL
, NULL
);
2214 c_str
= scm_i_string_chars (str
);
2216 for (k
= 0; k
< (len
+ 31) / 32; k
++)
2222 for (mask
= 1L; j
--; mask
<<= 1)
2237 scm_array_handle_release (&handle
);
2238 scm_remember_upto_here_1 (str
);
2245 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2248 long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2250 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
2252 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2254 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2255 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2260 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2268 res
= scm_cons (scm_i_cvref (SCM_ARRAY_V (ra
), i
, enclosed
),
2276 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2278 "Return a list consisting of all the elements, in order, of\n"
2280 #define FUNC_NAME s_scm_array_to_list
2282 if (scm_is_generalized_vector (v
))
2283 return scm_generalized_vector_to_list (v
);
2284 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
2285 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2287 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2292 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2294 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
2295 (SCM type
, SCM ndim
, SCM lst
),
2296 "Return an array of the type @var{type}\n"
2297 "with elements the same as those of @var{lst}.\n"
2299 "The argument @var{ndim} determines the number of dimensions\n"
2300 "of the array. It is either an exact integer, giving the\n"
2301 "number directly, or a list of exact integers, whose length\n"
2302 "specifies the number of dimensions and each element is the\n"
2303 "lower index bound of its dimension.")
2304 #define FUNC_NAME s_scm_list_to_typed_array
2312 if (scm_is_integer (ndim
))
2314 size_t k
= scm_to_size_t (ndim
);
2317 shape
= scm_cons (scm_length (row
), shape
);
2319 row
= scm_car (row
);
2326 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
2327 scm_sum (scm_sum (scm_car (ndim
),
2329 scm_from_int (-1))),
2331 ndim
= scm_cdr (ndim
);
2332 if (scm_is_pair (ndim
))
2333 row
= scm_car (row
);
2339 ra
= scm_make_typed_array (type
, SCM_UNSPECIFIED
,
2340 scm_reverse_x (shape
, SCM_EOL
));
2342 if (scm_is_null (shape
))
2344 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2345 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2348 if (!SCM_ARRAYP (ra
))
2350 size_t length
= scm_c_generalized_vector_length (ra
);
2351 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2352 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
2355 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2358 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2363 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2364 (SCM ndim
, SCM lst
),
2365 "Return an array with elements the same as those of @var{lst}.")
2366 #define FUNC_NAME s_scm_list_to_array
2368 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2373 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2375 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2376 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2379 return (scm_is_null (lst
));
2380 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2384 if (!scm_is_pair (lst
))
2386 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2388 lst
= SCM_CDR (lst
);
2390 if (!scm_is_null (lst
))
2397 if (!scm_is_pair (lst
))
2399 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
2401 lst
= SCM_CDR (lst
);
2403 if (!scm_is_null (lst
))
2409 #if SCM_ENABLE_DEPRECATED
2411 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2412 (SCM ndim
, SCM prot
, SCM lst
),
2413 "Return a uniform array of the type indicated by prototype\n"
2414 "@var{prot} with elements the same as those of @var{lst}.\n"
2415 "Elements must be of the appropriate type, no coercions are\n"
2418 "The argument @var{ndim} determines the number of dimensions\n"
2419 "of the array. It is either an exact integer, giving the\n"
2420 "number directly, or a list of exact integers, whose length\n"
2421 "specifies the number of dimensions and each element is the\n"
2422 "lower index bound of its dimension.")
2423 #define FUNC_NAME s_scm_list_to_uniform_array
2425 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2431 /* Print dimension DIM of ARRAY.
2435 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2436 SCM port
, scm_print_state
*pstate
)
2438 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
2441 scm_putc ('(', port
);
2443 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2445 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2446 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2449 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
2451 if (idx
< dim_spec
->ubnd
)
2452 scm_putc (' ', port
);
2453 base
+= dim_spec
->inc
;
2456 scm_putc (')', port
);
2460 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2464 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2466 long ndim
= SCM_ARRAY_NDIM (array
);
2467 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2468 SCM v
= SCM_ARRAY_V (array
);
2469 unsigned long base
= SCM_ARRAY_BASE (array
);
2472 scm_putc ('#', port
);
2473 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2474 scm_intprint (ndim
, 10, port
);
2475 if (scm_is_uniform_vector (v
))
2476 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2477 else if (scm_is_bitvector (v
))
2478 scm_puts ("b", port
);
2479 else if (scm_is_string (v
))
2480 scm_puts ("a", port
);
2481 else if (!scm_is_vector (v
))
2482 scm_puts ("?", port
);
2484 for (i
= 0; i
< ndim
; i
++)
2485 if (dim_specs
[i
].lbnd
!= 0)
2487 for (i
= 0; i
< ndim
; i
++)
2489 scm_putc ('@', port
);
2490 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2495 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2499 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2503 scm_putc ('#', port
);
2504 base
= SCM_ARRAY_BASE (array
);
2505 scm_puts ("<enclosed-array ", port
);
2506 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2507 scm_putc ('>', port
);
2511 /* Read an array. This function can also read vectors and uniform
2512 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2515 C is the first character read after the '#'.
2519 tag_to_type (const char *tag
, SCM port
)
2521 #if SCM_ENABLE_DEPRECATED
2523 /* Recognize the old syntax.
2525 const char *instead
;
2557 if (instead
&& tag
[1] == '\0')
2559 scm_c_issue_deprecation_warning_fmt
2560 ("The tag '%c' is deprecated for uniform vectors. "
2561 "Use '%s' instead.", tag
[0], instead
);
2562 return scm_from_locale_symbol (instead
);
2567 return scm_from_locale_symbol (tag
);
2571 scm_i_read_array (SCM port
, int c
)
2578 SCM lower_bounds
, elements
;
2580 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2581 the array code can not deal with zero-length dimensions yet, and
2582 we want to allow zero-length vectors, of course.
2586 scm_ungetc (c
, port
);
2587 return scm_vector (scm_read (port
));
2590 /* Disambiguate between '#f' and uniform floating point vectors.
2594 c
= scm_getc (port
);
2595 if (c
!= '3' && c
!= '6')
2598 scm_ungetc (c
, port
);
2605 goto continue_reading_tag
;
2608 /* Read rank. We disallow arrays of rank zero since they do not
2609 seem to work reliably yet. */
2612 while ('0' <= c
&& c
<= '9')
2614 rank
= 10*rank
+ c
-'0';
2616 c
= scm_getc (port
);
2621 scm_i_input_error (NULL
, port
,
2622 "array rank must be positive", SCM_EOL
);
2626 continue_reading_tag
:
2627 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2630 c
= scm_getc (port
);
2632 tag
[tag_len
] = '\0';
2634 /* Read lower bounds. */
2635 lower_bounds
= SCM_EOL
;
2638 /* Yeah, right, we should use some ready-made integer parsing
2645 c
= scm_getc (port
);
2649 c
= scm_getc (port
);
2651 while ('0' <= c
&& c
<= '9')
2653 lbnd
= 10*lbnd
+ c
-'0';
2654 c
= scm_getc (port
);
2656 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2659 /* Read nested lists of elements.
2662 scm_i_input_error (NULL
, port
,
2663 "missing '(' in vector or array literal",
2665 scm_ungetc (c
, port
);
2666 elements
= scm_read (port
);
2668 if (scm_is_null (lower_bounds
))
2669 lower_bounds
= scm_from_size_t (rank
);
2670 else if (scm_ilength (lower_bounds
) != rank
)
2671 scm_i_input_error (NULL
, port
,
2672 "the number of lower bounds must match the array rank",
2675 /* Construct array. */
2676 return scm_list_to_typed_array (tag_to_type (tag
, port
),
2682 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2684 scm_iprin1 (exp
, port
, pstate
);
2688 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2691 #define FUNC_NAME s_scm_array_type
2693 if (SCM_ARRAYP (ra
))
2694 return scm_i_generalized_vector_type (SCM_ARRAY_V (ra
));
2695 else if (scm_is_generalized_vector (ra
))
2696 return scm_i_generalized_vector_type (ra
);
2697 else if (SCM_ENCLOSED_ARRAYP (ra
))
2698 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2700 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2704 #if SCM_ENABLE_DEPRECATED
2706 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2708 "Return an object that would produce an array of the same type\n"
2709 "as @var{array}, if used as the @var{prototype} for\n"
2710 "@code{make-uniform-array}.")
2711 #define FUNC_NAME s_scm_array_prototype
2713 if (SCM_ARRAYP (ra
))
2714 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2715 else if (scm_is_generalized_vector (ra
))
2716 return scm_i_get_old_prototype (ra
);
2717 else if (SCM_ENCLOSED_ARRAYP (ra
))
2718 return SCM_UNSPECIFIED
;
2720 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2727 array_mark (SCM ptr
)
2729 return SCM_ARRAY_V (ptr
);
2733 array_free (SCM ptr
)
2735 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2736 (sizeof (scm_t_array
)
2737 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2745 scm_tc16_array
= scm_make_smob_type ("array", 0);
2746 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2747 scm_set_smob_free (scm_tc16_array
, array_free
);
2748 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2749 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2751 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2752 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2753 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2754 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2755 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2757 scm_add_feature ("array");
2759 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2760 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2761 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2762 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2764 init_type_creator_table ();
2766 #include "libguile/unif.x"