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
));
256 #if SCM_ENABLE_DEPRECATED
258 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
260 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
262 #define FUNC_NAME s_scm_array_p
264 if (!SCM_UNBNDP (prot
))
266 scm_c_issue_deprecation_warning
267 ("Using prototypes with `array?' is deprecated."
268 " Use `typed-array?' instead.");
270 return scm_typed_array_p (obj
, prototype_to_type (prot
));
273 return scm_from_bool (scm_is_array (obj
));
277 #else /* !SCM_ENABLE_DEPRECATED */
279 /* We keep the old 2-argument C prototype for a while although the old
280 PROT argument is always ignored now. C code should probably use
281 scm_is_array or scm_is_typed_array anyway.
284 SCM_DEFINE (scm_array_p
, "array?", 1, 0, 0,
285 (SCM obj
, SCM unused
),
286 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
288 #define FUNC_NAME s_scm_array_p
290 return scm_from_bool (scm_is_array (obj
));
294 #endif /* !SCM_ENABLE_DEPRECATED */
297 SCM_DEFINE (scm_typed_array_p
, "typed-array?", 2, 0, 0,
299 "Return @code{#t} if the @var{obj} is an array of type\n"
300 "@var{type}, and @code{#f} if not.")
301 #define FUNC_NAME s_scm_typed_array_p
303 return scm_from_bool (scm_is_typed_array (obj
, type
));
308 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
310 "Return the number of dimensions of the array @var{array.}\n")
311 #define FUNC_NAME s_scm_array_rank
313 if (scm_is_generalized_vector (array
))
314 return scm_from_int (1);
316 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
317 return scm_from_size_t (SCM_ARRAY_NDIM (array
));
319 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
324 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
326 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
327 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
329 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
331 #define FUNC_NAME s_scm_array_dimensions
333 if (scm_is_generalized_vector (ra
))
334 return scm_list_1 (scm_generalized_vector_length (ra
));
336 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
342 k
= SCM_ARRAY_NDIM (ra
);
343 s
= SCM_ARRAY_DIMS (ra
);
345 res
= scm_cons (s
[k
].lbnd
346 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
347 scm_from_long (s
[k
].ubnd
),
349 : scm_from_long (1 + s
[k
].ubnd
),
354 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
359 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
361 "Return the root vector of a shared array.")
362 #define FUNC_NAME s_scm_shared_array_root
364 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
365 SCM_ARG1
, FUNC_NAME
);
366 return SCM_ARRAY_V (ra
);
371 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
373 "Return the root vector index of the first element in the array.")
374 #define FUNC_NAME s_scm_shared_array_offset
376 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
377 SCM_ARG1
, FUNC_NAME
);
378 return scm_from_int (SCM_ARRAY_BASE (ra
));
383 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
385 "For each dimension, return the distance between elements in the root vector.")
386 #define FUNC_NAME s_scm_shared_array_increments
392 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
393 SCM_ARG1
, FUNC_NAME
);
394 k
= SCM_ARRAY_NDIM (ra
);
395 s
= SCM_ARRAY_DIMS (ra
);
397 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
403 static char s_bad_ind
[] = "Bad scm_array index";
407 scm_aind (SCM ra
, SCM args
, const char *what
)
411 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
412 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
413 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
415 if (scm_is_integer (args
))
418 scm_error_num_args_subr (what
);
419 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
421 while (k
&& scm_is_pair (args
))
423 ind
= SCM_CAR (args
);
424 args
= SCM_CDR (args
);
425 if (!scm_is_integer (ind
))
426 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
427 j
= scm_to_long (ind
);
428 if (j
< s
->lbnd
|| j
> s
->ubnd
)
429 scm_out_of_range (what
, ind
);
430 pos
+= (j
- s
->lbnd
) * (s
->inc
);
434 if (k
!= 0 || !scm_is_null (args
))
435 scm_error_num_args_subr (what
);
442 scm_i_make_ra (int ndim
, scm_t_bits tag
)
445 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
446 scm_gc_malloc ((sizeof (scm_t_array
) +
447 ndim
* sizeof (scm_t_array_dim
)),
449 SCM_ARRAY_V (ra
) = SCM_BOOL_F
;
454 scm_make_ra (int ndim
)
456 return scm_i_make_ra (ndim
, scm_tc16_array
);
460 static char s_bad_spec
[] = "Bad scm_array dimension";
463 /* Increments will still need to be set. */
466 scm_shap2ra (SCM args
, const char *what
)
470 int ndim
= scm_ilength (args
);
472 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
474 ra
= scm_make_ra (ndim
);
475 SCM_ARRAY_BASE (ra
) = 0;
476 s
= SCM_ARRAY_DIMS (ra
);
477 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
479 spec
= SCM_CAR (args
);
480 if (scm_is_integer (spec
))
482 if (scm_to_long (spec
) < 0)
483 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
485 s
->ubnd
= scm_to_long (spec
) - 1;
490 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
491 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
492 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
494 if (!scm_is_pair (sp
)
495 || !scm_is_integer (SCM_CAR (sp
))
496 || !scm_is_null (SCM_CDR (sp
)))
497 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
498 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
505 SCM_DEFINE (scm_make_typed_array
, "make-typed-array", 2, 0, 1,
506 (SCM type
, SCM fill
, SCM bounds
),
507 "Create and return an array of type @var{type}.")
508 #define FUNC_NAME s_scm_make_typed_array
512 creator_proc
*creator
;
515 creator
= type_to_creator (type
);
516 ra
= scm_shap2ra (bounds
, FUNC_NAME
);
517 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
518 s
= SCM_ARRAY_DIMS (ra
);
519 k
= SCM_ARRAY_NDIM (ra
);
524 SCM_ASSERT_RANGE (1, bounds
, s
[k
].lbnd
<= s
[k
].ubnd
);
525 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
528 if (scm_is_eq (fill
, SCM_BOOL_F
) && !scm_is_eq (type
, SCM_BOOL_T
))
529 fill
= SCM_UNDEFINED
;
531 SCM_ARRAY_V (ra
) = creator (scm_from_size_t (rlen
), fill
);
533 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
534 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
535 return SCM_ARRAY_V (ra
);
540 SCM_DEFINE (scm_make_array
, "make-array", 1, 0, 1,
541 (SCM fill
, SCM bounds
),
542 "Create and return an array.")
543 #define FUNC_NAME s_scm_make_array
545 return scm_make_typed_array (SCM_BOOL_T
, fill
, bounds
);
549 #if SCM_ENABLE_DEPRECATED
551 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
552 (SCM dims
, SCM prot
, SCM fill
),
553 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
554 "Create and return a uniform array or vector of type\n"
555 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
556 "length @var{length}. If @var{fill} is supplied, it's used to\n"
557 "fill the array, otherwise @var{prototype} is used.")
558 #define FUNC_NAME s_scm_dimensions_to_uniform_array
560 scm_c_issue_deprecation_warning
561 ("`dimensions->uniform-array' is deprecated. "
562 "Use `make-typed-array' instead.");
564 if (scm_is_integer (dims
))
565 dims
= scm_list_1 (dims
);
566 return scm_make_typed_array (prototype_to_type (prot
), fill
, dims
);
573 scm_ra_set_contp (SCM ra
)
575 /* XXX - correct? one-dimensional arrays are always 'contiguous',
578 size_t k
= SCM_ARRAY_NDIM (ra
);
581 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
584 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
586 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
589 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
590 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
593 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
597 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
598 (SCM oldra
, SCM mapfunc
, SCM dims
),
599 "@code{make-shared-array} can be used to create shared subarrays of other\n"
600 "arrays. The @var{mapper} is a function that translates coordinates in\n"
601 "the new array into coordinates in the old array. A @var{mapper} must be\n"
602 "linear, and its range must stay within the bounds of the old array, but\n"
603 "it can be otherwise arbitrary. A simple example:\n"
605 "(define fred (make-array #f 8 8))\n"
606 "(define freds-diagonal\n"
607 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
608 "(array-set! freds-diagonal 'foo 3)\n"
609 "(array-ref fred 3 3) @result{} foo\n"
610 "(define freds-center\n"
611 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
612 "(array-ref freds-center 0 0) @result{} foo\n"
614 #define FUNC_NAME s_scm_make_shared_array
620 long old_min
, new_min
, old_max
, new_max
;
623 SCM_VALIDATE_REST_ARGUMENT (dims
);
624 SCM_VALIDATE_ARRAY (1, oldra
);
625 SCM_VALIDATE_PROC (2, mapfunc
);
626 ra
= scm_shap2ra (dims
, FUNC_NAME
);
627 if (SCM_ARRAYP (oldra
))
629 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
630 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
631 s
= SCM_ARRAY_DIMS (oldra
);
632 k
= SCM_ARRAY_NDIM (oldra
);
636 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
638 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
643 SCM_ARRAY_V (ra
) = oldra
;
645 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
648 s
= SCM_ARRAY_DIMS (ra
);
649 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
651 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
652 if (s
[k
].ubnd
< s
[k
].lbnd
)
654 if (1 == SCM_ARRAY_NDIM (ra
))
655 ra
= make_typed_vector (scm_array_type (ra
), 0);
657 SCM_ARRAY_V (ra
) = make_typed_vector (scm_array_type (ra
), 0);
661 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
662 if (SCM_ARRAYP (oldra
))
663 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
666 if (!scm_is_integer (imap
))
668 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
669 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
670 imap
= SCM_CAR (imap
);
672 i
= scm_to_size_t (imap
);
674 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
676 k
= SCM_ARRAY_NDIM (ra
);
679 if (s
[k
].ubnd
> s
[k
].lbnd
)
681 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
682 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
683 if (SCM_ARRAYP (oldra
))
685 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
688 if (!scm_is_integer (imap
))
690 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
691 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
692 imap
= SCM_CAR (imap
);
694 s
[k
].inc
= scm_to_long (imap
) - i
;
698 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
700 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
703 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
704 indptr
= SCM_CDR (indptr
);
706 if (old_min
> new_min
|| old_max
< new_max
)
707 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
708 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
710 SCM v
= SCM_ARRAY_V (ra
);
711 unsigned long int length
= scm_to_ulong (scm_uniform_vector_length (v
));
712 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
714 if (s
->ubnd
< s
->lbnd
)
715 return make_typed_vector (scm_array_type (ra
), 0);
717 scm_ra_set_contp (ra
);
723 /* args are RA . DIMS */
724 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
726 "Return an array sharing contents with @var{array}, but with\n"
727 "dimensions arranged in a different order. There must be one\n"
728 "@var{dim} argument for each dimension of @var{array}.\n"
729 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
730 "and the rank of the array to be returned. Each integer in that\n"
731 "range must appear at least once in the argument list.\n"
733 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
734 "dimensions in the array to be returned, their positions in the\n"
735 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
736 "may have the same value, in which case the returned array will\n"
737 "have smaller rank than @var{array}.\n"
740 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
741 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
742 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
743 " #2((a 4) (b 5) (c 6))\n"
745 #define FUNC_NAME s_scm_transpose_array
748 SCM
const *ve
= &vargs
;
749 scm_t_array_dim
*s
, *r
;
752 SCM_VALIDATE_REST_ARGUMENT (args
);
753 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
755 if (scm_is_generalized_vector (ra
))
757 /* Make sure that we are called with a single zero as
760 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
761 SCM_WRONG_NUM_ARGS ();
762 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
763 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
767 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
769 vargs
= scm_vector (args
);
770 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
771 SCM_WRONG_NUM_ARGS ();
772 ve
= SCM_VELTS (vargs
);
774 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
776 i
= scm_to_signed_integer (ve
[k
], 0, SCM_ARRAY_NDIM(ra
));
781 res
= scm_make_ra (ndim
);
782 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
783 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
786 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
787 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
789 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
791 i
= scm_to_int (ve
[k
]);
792 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
793 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
794 if (r
->ubnd
< r
->lbnd
)
803 if (r
->ubnd
> s
->ubnd
)
805 if (r
->lbnd
< s
->lbnd
)
807 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
814 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
815 scm_ra_set_contp (res
);
819 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
823 /* args are RA . AXES */
824 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
826 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
827 "the rank of @var{array}. @var{enclose-array} returns an array\n"
828 "resembling an array of shared arrays. The dimensions of each shared\n"
829 "array are the same as the @var{dim}th dimensions of the original array,\n"
830 "the dimensions of the outer array are the same as those of the original\n"
831 "array that did not match a @var{dim}.\n\n"
832 "An enclosed array is not a general Scheme array. Its elements may not\n"
833 "be set using @code{array-set!}. Two references to the same element of\n"
834 "an enclosed array will be @code{equal?} but will not in general be\n"
835 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
836 "enclosed array is unspecified.\n\n"
839 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
840 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
841 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
842 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
844 #define FUNC_NAME s_scm_enclose_array
846 SCM axv
, res
, ra_inr
;
848 scm_t_array_dim vdim
, *s
= &vdim
;
849 int ndim
, j
, k
, ninr
, noutr
;
851 SCM_VALIDATE_REST_ARGUMENT (axes
);
852 if (scm_is_null (axes
))
853 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
854 ninr
= scm_ilength (axes
);
856 SCM_WRONG_NUM_ARGS ();
857 ra_inr
= scm_make_ra (ninr
);
859 if (scm_is_generalized_vector (ra
))
862 s
->ubnd
= scm_to_long (scm_uniform_vector_length (ra
)) - 1;
864 SCM_ARRAY_V (ra_inr
) = ra
;
865 SCM_ARRAY_BASE (ra_inr
) = 0;
868 else if (SCM_ARRAYP (ra
))
870 s
= SCM_ARRAY_DIMS (ra
);
871 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
872 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
873 ndim
= SCM_ARRAY_NDIM (ra
);
876 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
880 SCM_WRONG_NUM_ARGS ();
881 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
882 res
= scm_i_make_ra (noutr
, scm_tc16_enclosed_array
);
883 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
884 SCM_ARRAY_V (res
) = ra_inr
;
885 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
887 if (!scm_is_integer (SCM_CAR (axes
)))
888 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
889 j
= scm_to_int (SCM_CAR (axes
));
890 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
891 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
892 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
893 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
895 c_axv
= scm_i_string_chars (axv
);
896 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
900 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
901 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
902 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
904 scm_remember_upto_here_1 (axv
);
905 scm_ra_set_contp (ra_inr
);
906 scm_ra_set_contp (res
);
913 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
915 "Return @code{#t} if its arguments would be acceptable to\n"
917 #define FUNC_NAME s_scm_array_in_bounds_p
919 SCM res
= SCM_BOOL_T
;
921 SCM_VALIDATE_REST_ARGUMENT (args
);
923 if (scm_is_generalized_vector (v
))
927 if (!scm_is_pair (args
))
928 SCM_WRONG_NUM_ARGS ();
929 ind
= scm_to_long (SCM_CAR (args
));
930 args
= SCM_CDR (args
);
931 res
= scm_from_bool (ind
>= 0
932 && ind
< scm_c_generalized_vector_length (v
));
934 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
936 size_t k
= SCM_ARRAY_NDIM (v
);
937 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (v
);
943 if (!scm_is_pair (args
))
944 SCM_WRONG_NUM_ARGS ();
945 ind
= scm_to_long (SCM_CAR (args
));
946 args
= SCM_CDR (args
);
949 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
952 /* We do not stop the checking after finding a violation
953 since we want to validate the type-correctness and
954 number of arguments in any case.
960 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
962 if (!scm_is_null (args
))
963 SCM_WRONG_NUM_ARGS ();
970 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
974 int k
= SCM_ARRAY_NDIM (v
);
975 SCM res
= scm_make_ra (k
);
976 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
977 SCM_ARRAY_BASE (res
) = pos
;
980 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
981 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
982 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
987 return scm_c_generalized_vector_ref (v
, pos
);
991 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
993 return scm_i_cvref (v
, pos
, 0);
996 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
998 "Return the element at the @code{(index1, index2)} element in\n"
1000 #define FUNC_NAME s_scm_array_ref
1005 if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1007 enclosed
= SCM_ENCLOSED_ARRAYP (v
);
1008 pos
= scm_aind (v
, args
, FUNC_NAME
);
1009 v
= SCM_ARRAY_V (v
);
1014 if (SCM_NIMP (args
))
1016 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
1017 pos
= scm_to_long (SCM_CAR (args
));
1018 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1021 pos
= scm_to_long (args
);
1022 length
= scm_c_generalized_vector_length (v
);
1023 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1026 return scm_i_cvref (v
, pos
, enclosed
);
1029 scm_wrong_num_args (NULL
);
1031 scm_out_of_range (NULL
, scm_from_long (pos
));
1036 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1037 (SCM v
, SCM obj
, SCM args
),
1038 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1039 "@var{new-value}. The value returned by array-set! is unspecified.")
1040 #define FUNC_NAME s_scm_array_set_x
1046 pos
= scm_aind (v
, args
, FUNC_NAME
);
1047 v
= SCM_ARRAY_V (v
);
1049 else if (SCM_ENCLOSED_ARRAYP (v
))
1050 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-enclosed array");
1051 else if (scm_is_generalized_vector (v
))
1054 if (scm_is_pair (args
))
1056 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1057 pos
= scm_to_long (SCM_CAR (args
));
1060 pos
= scm_to_long (args
);
1061 length
= scm_c_generalized_vector_length (v
);
1062 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1065 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1067 scm_c_generalized_vector_set_x (v
, pos
, obj
);
1068 return SCM_UNSPECIFIED
;
1071 scm_out_of_range (NULL
, scm_from_long (pos
));
1073 scm_wrong_num_args (NULL
);
1077 /* attempts to unroll an array into a one-dimensional array.
1078 returns the unrolled array or #f if it can't be done. */
1079 /* if strict is not SCM_UNDEFINED, return #f if returned array
1080 wouldn't have contiguous elements. */
1081 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1082 (SCM ra
, SCM strict
),
1083 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1084 "without changing their order (last subscript changing fastest), then\n"
1085 "@code{array-contents} returns that shared array, otherwise it returns\n"
1086 "@code{#f}. All arrays made by @var{make-array} and\n"
1087 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1088 "@var{make-shared-array} may not be.\n\n"
1089 "If the optional argument @var{strict} is provided, a shared array will\n"
1090 "be returned only if its elements are stored internally contiguous in\n"
1092 #define FUNC_NAME s_scm_array_contents
1096 if (scm_is_generalized_vector (ra
))
1099 if (SCM_ARRAYP (ra
))
1101 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1102 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1104 for (k
= 0; k
< ndim
; k
++)
1105 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1106 if (!SCM_UNBNDP (strict
))
1108 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1110 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1112 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1113 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1120 SCM v
= SCM_ARRAY_V (ra
);
1121 size_t length
= scm_c_generalized_vector_length (v
);
1122 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1126 sra
= scm_make_ra (1);
1127 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1128 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1129 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1130 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1131 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1134 else if (SCM_ENCLOSED_ARRAYP (ra
))
1135 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1137 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1143 scm_ra2contig (SCM ra
, int copy
)
1148 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1149 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1150 k
= SCM_ARRAY_NDIM (ra
);
1151 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1153 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1155 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1156 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1157 0 == len
% SCM_LONG_BIT
))
1160 ret
= scm_make_ra (k
);
1161 SCM_ARRAY_BASE (ret
) = 0;
1164 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1165 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1166 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1167 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1169 SCM_ARRAY_V (ret
) = make_typed_vector (scm_array_type (ra
), inc
);
1171 scm_array_copy_x (ra
, ret
);
1177 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1178 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1179 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1180 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1181 "binary objects from @var{port-or-fdes}.\n"
1182 "If an end of file is encountered,\n"
1183 "the objects up to that point are put into @var{ura}\n"
1184 "(starting at the beginning) and the remainder of the array is\n"
1186 "The optional arguments @var{start} and @var{end} allow\n"
1187 "a specified region of a vector (or linearized array) to be read,\n"
1188 "leaving the remainder of the vector unchanged.\n\n"
1189 "@code{uniform-array-read!} returns the number of objects read.\n"
1190 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1191 "returned by @code{(current-input-port)}.")
1192 #define FUNC_NAME s_scm_uniform_array_read_x
1194 if (SCM_UNBNDP (port_or_fd
))
1195 port_or_fd
= scm_cur_inp
;
1197 if (scm_is_uniform_vector (ura
))
1199 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1201 else if (SCM_ARRAYP (ura
))
1203 size_t base
, vlen
, cstart
, cend
;
1206 cra
= scm_ra2contig (ura
, 0);
1207 base
= SCM_ARRAY_BASE (cra
);
1208 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1209 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1213 if (!SCM_UNBNDP (start
))
1215 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1216 if (!SCM_UNBNDP (end
))
1217 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1220 ans
= scm_uniform_vector_read_x (SCM_ARRAY_V (cra
), port_or_fd
,
1221 scm_from_size_t (base
+ cstart
),
1222 scm_from_size_t (base
+ cend
));
1224 if (!scm_is_eq (cra
, ura
))
1225 scm_array_copy_x (cra
, ura
);
1228 else if (SCM_ENCLOSED_ARRAYP (ura
))
1229 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1231 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1235 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1236 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1237 "Writes all elements of @var{ura} as binary objects to\n"
1238 "@var{port-or-fdes}.\n\n"
1239 "The optional arguments @var{start}\n"
1240 "and @var{end} allow\n"
1241 "a specified region of a vector (or linearized array) to be written.\n\n"
1242 "The number of objects actually written is returned.\n"
1243 "@var{port-or-fdes} may be\n"
1244 "omitted, in which case it defaults to the value returned by\n"
1245 "@code{(current-output-port)}.")
1246 #define FUNC_NAME s_scm_uniform_array_write
1248 if (SCM_UNBNDP (port_or_fd
))
1249 port_or_fd
= scm_cur_outp
;
1251 if (scm_is_uniform_vector (ura
))
1253 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1255 else if (SCM_ARRAYP (ura
))
1257 size_t base
, vlen
, cstart
, cend
;
1260 cra
= scm_ra2contig (ura
, 1);
1261 base
= SCM_ARRAY_BASE (cra
);
1262 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1263 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1267 if (!SCM_UNBNDP (start
))
1269 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1270 if (!SCM_UNBNDP (end
))
1271 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1274 ans
= scm_uniform_vector_write (SCM_ARRAY_V (cra
), port_or_fd
,
1275 scm_from_size_t (base
+ cstart
),
1276 scm_from_size_t (base
+ cend
));
1280 else if (SCM_ENCLOSED_ARRAYP (ura
))
1281 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1283 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1290 static scm_t_bits scm_tc16_bitvector
;
1292 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1293 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1294 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1297 bitvector_free (SCM vec
)
1299 scm_gc_free (BITVECTOR_BITS (vec
),
1300 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1306 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1308 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1309 size_t word_len
= (bit_len
+31)/32;
1310 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1313 scm_puts ("#*", port
);
1314 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1316 scm_t_uint32 mask
= 1;
1317 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1318 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1325 bitvector_equalp (SCM vec1
, SCM vec2
)
1327 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1328 size_t word_len
= (bit_len
+ 31) / 32;
1329 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1330 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1331 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1333 /* compare lengths */
1334 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1336 /* avoid underflow in word_len-1 below. */
1339 /* compare full words */
1340 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1342 /* compare partial last words */
1343 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1349 scm_is_bitvector (SCM vec
)
1351 return IS_BITVECTOR (vec
);
1354 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1356 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1357 "return @code{#f}.")
1358 #define FUNC_NAME s_scm_bitvector_p
1360 return scm_from_bool (scm_is_bitvector (obj
));
1365 scm_c_make_bitvector (size_t len
, SCM fill
)
1367 size_t word_len
= (len
+ 31) / 32;
1371 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1373 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1375 if (!SCM_UNBNDP (fill
))
1376 scm_bitvector_fill_x (res
, fill
);
1381 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1382 (SCM len
, SCM fill
),
1383 "Create a new bitvector of length @var{len} and\n"
1384 "optionally initialize all elements to @var{fill}.")
1385 #define FUNC_NAME s_scm_make_bitvector
1387 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1391 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1393 "Create a new bitvector with the arguments as elements.")
1394 #define FUNC_NAME s_scm_bitvector
1396 return scm_list_to_bitvector (bits
);
1401 scm_c_bitvector_length (SCM vec
)
1403 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1404 return BITVECTOR_LENGTH (vec
);
1407 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1409 "Return the length of the bitvector @var{vec}.")
1410 #define FUNC_NAME s_scm_bitvector_length
1412 return scm_from_size_t (scm_c_bitvector_length (vec
));
1416 const scm_t_uint32
*
1417 scm_bitvector_elements (SCM vec
)
1419 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1420 return BITVECTOR_BITS (vec
);
1424 scm_bitvector_release_elements (SCM vec
)
1426 /* Nothing to do right now, but this function might come in handy
1427 when bitvectors need to be locked when giving away a pointer
1430 Also, a call to scm_bitvector_release_elements acts like
1431 scm_remember_upto_here, which is needed in any case.
1434 scm_remember_upto_here_1 (vec
);
1438 scm_frame_bitvector_release_elements (SCM vec
)
1440 scm_frame_unwind_handler_with_scm (scm_bitvector_release_elements
, vec
,
1441 SCM_F_WIND_EXPLICITLY
);
1445 scm_bitvector_writable_elements (SCM vec
)
1447 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1448 return BITVECTOR_BITS (vec
);
1452 scm_bitvector_release_writable_elements (SCM vec
)
1454 scm_remember_upto_here_1 (vec
);
1458 scm_frame_bitvector_release_writable_elements (SCM vec
)
1460 scm_frame_unwind_handler_with_scm
1461 (scm_bitvector_release_writable_elements
, vec
,
1462 SCM_F_WIND_EXPLICITLY
);
1466 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1468 if (idx
< scm_c_bitvector_length (vec
))
1470 const scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1471 SCM res
= (bits
[idx
/32] & (1L << (idx
%32)))? SCM_BOOL_T
: SCM_BOOL_F
;
1472 scm_bitvector_release_elements (vec
);
1476 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1479 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1481 "Return the element at index @var{idx} of the bitvector\n"
1483 #define FUNC_NAME s_scm_bitvector_ref
1485 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1490 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1492 if (idx
< scm_c_bitvector_length (vec
))
1494 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1495 scm_t_uint32 mask
= 1L << (idx
%32);
1496 if (scm_is_true (val
))
1497 bits
[idx
/32] |= mask
;
1499 bits
[idx
/32] &= ~mask
;
1500 scm_bitvector_release_writable_elements (vec
);
1503 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1506 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1507 (SCM vec
, SCM idx
, SCM val
),
1508 "Set the element at index @var{idx} of the bitvector\n"
1509 "@var{vec} when @var{val} is true, else clear it.")
1510 #define FUNC_NAME s_scm_bitvector_set_x
1512 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1513 return SCM_UNSPECIFIED
;
1517 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1519 "Set all elements of the bitvector\n"
1520 "@var{vec} when @var{val} is true, else clear them.")
1521 #define FUNC_NAME s_scm_bitvector_fill_x
1523 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1524 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1525 size_t word_len
= (bit_len
+ 31) / 32;
1526 memset (bits
, scm_is_true (val
)? -1:0, sizeof (scm_t_uint32
) * word_len
);
1527 scm_bitvector_release_writable_elements (vec
);
1528 return SCM_UNSPECIFIED
;
1532 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1534 "Return a new bitvector initialized with the elements\n"
1536 #define FUNC_NAME s_scm_list_to_bitvector
1538 size_t bit_len
= scm_to_size_t (scm_length (list
));
1539 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1540 size_t word_len
= (bit_len
+31)/32;
1541 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1544 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1546 scm_t_uint32 mask
= 1;
1548 for (j
= 0; j
< 32 && j
< bit_len
;
1549 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1550 if (scm_is_true (SCM_CAR (list
)))
1554 scm_bitvector_release_writable_elements (vec
);
1559 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1561 "Return a new list initialized with the elements\n"
1562 "of the bitvector @var{vec}.")
1563 #define FUNC_NAME s_scm_bitvector_to_list
1565 size_t bit_len
= scm_c_bitvector_length (vec
);
1567 size_t word_len
= (bit_len
+31)/32;
1568 const scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1571 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1573 scm_t_uint32 mask
= 1;
1574 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1575 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1578 scm_bitvector_release_elements (vec
);
1579 return scm_reverse_x (res
, SCM_EOL
);
1583 /* From mmix-arith.w by Knuth.
1585 Here's a fun way to count the number of bits in a tetrabyte.
1587 [This classical trick is called the ``Gillies--Miller method for
1588 sideways addition'' in {\sl The Preparation of Programs for an
1589 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1590 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1591 the tricks used here were suggested by Balbir Singh, Peter
1592 Rossmanith, and Stefan Schwoon.]
1596 count_ones (scm_t_uint32 x
)
1598 x
=x
-((x
>>1)&0x55555555);
1599 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1600 x
=(x
+(x
>>4))&0x0f0f0f0f;
1602 return (x
+(x
>>16)) & 0xff;
1605 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1606 (SCM b
, SCM bitvector
),
1607 "Return the number of occurrences of the boolean @var{b} in\n"
1609 #define FUNC_NAME s_scm_bit_count
1611 size_t bit_len
= scm_c_bitvector_length (bitvector
);
1612 size_t word_len
= (bit_len
+ 31) / 32;
1613 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1614 const scm_t_uint32
*bits
= scm_bitvector_elements (bitvector
);
1616 int bit
= scm_to_bool (b
);
1617 size_t count
= 0, i
;
1622 for (i
= 0; i
< word_len
-1; i
++)
1623 count
+= count_ones (bits
[i
]);
1624 count
+= count_ones (bits
[i
] & last_mask
);
1626 scm_bitvector_release_elements (bitvector
);
1627 return scm_from_size_t (bit
? count
: bit_len
-count
);
1631 /* returns 32 for x == 0.
1634 find_first_one (scm_t_uint32 x
)
1637 /* do a binary search in x. */
1638 if ((x
& 0xFFFF) == 0)
1639 x
>>= 16, pos
+= 16;
1640 if ((x
& 0xFF) == 0)
1651 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1652 (SCM item
, SCM v
, SCM k
),
1653 "Return the index of the first occurrance of @var{item} in bit\n"
1654 "vector @var{v}, starting from @var{k}. If there is no\n"
1655 "@var{item} entry between @var{k} and the end of\n"
1656 "@var{bitvector}, then return @code{#f}. For example,\n"
1659 "(bit-position #t #*000101 0) @result{} 3\n"
1660 "(bit-position #f #*0001111 3) @result{} #f\n"
1662 #define FUNC_NAME s_scm_bit_position
1664 size_t bit_len
= scm_c_bitvector_length (v
);
1665 size_t word_len
= (bit_len
+ 31) / 32;
1666 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1667 const scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1668 size_t first_bit
= scm_to_unsigned_integer (k
, 0, bit_len
);
1669 size_t first_word
= first_bit
/ 32;
1670 scm_t_uint32 first_mask
= ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1673 int bit
= scm_to_bool (item
);
1675 SCM res
= SCM_BOOL_F
;
1680 for (i
= first_word
; i
< word_len
; i
++)
1682 w
= (bit
? bits
[i
] : ~bits
[i
]);
1683 if (i
== first_word
)
1685 if (i
== word_len
-1)
1689 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1694 scm_bitvector_release_elements (v
);
1699 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1700 (SCM v
, SCM kv
, SCM obj
),
1701 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1702 "selecting the entries to change. The return value is\n"
1705 "If @var{kv} is a bit vector, then those entries where it has\n"
1706 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1707 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1708 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1709 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1712 "(define bv #*01000010)\n"
1713 "(bit-set*! bv #*10010001 #t)\n"
1715 "@result{} #*11010011\n"
1718 "If @var{kv} is a u32vector, then its elements are\n"
1719 "indices into @var{v} which are set to @var{obj}.\n"
1722 "(define bv #*01000010)\n"
1723 "(bit-set*! bv #u32(5 2 7) #t)\n"
1725 "@result{} #*01100111\n"
1727 #define FUNC_NAME s_scm_bit_set_star_x
1729 if (scm_is_bitvector (kv
))
1731 size_t bit_len
= scm_c_bitvector_length (kv
);
1732 size_t word_len
= (bit_len
+ 31) / 32;
1733 scm_t_uint32
*bits1
;
1734 const scm_t_uint32
*bits2
;
1736 int bit
= scm_to_bool (obj
);
1738 if (scm_c_bitvector_length (v
) != bit_len
)
1739 scm_misc_error (NULL
,
1740 "bit vectors must have equal length",
1743 bits1
= scm_bitvector_writable_elements (v
);
1744 bits2
= scm_bitvector_elements (kv
);
1747 for (i
= 0; i
< word_len
; i
++)
1748 bits1
[i
] &= ~bits2
[i
];
1750 for (i
= 0; i
< word_len
; i
++)
1751 bits1
[i
] |= bits2
[i
];
1753 scm_bitvector_release_elements (kv
);
1754 scm_bitvector_release_writable_elements (v
);
1756 else if (scm_is_true (scm_u32vector_p (kv
)))
1759 const scm_t_uint32
*indices
;
1761 /* assert that obj is a boolean.
1765 scm_frame_begin (0);
1767 ulen
= scm_c_uniform_vector_length (kv
);
1768 indices
= scm_u32vector_elements (kv
);
1769 scm_frame_uniform_vector_release_elements (kv
);
1771 for (i
= 0; i
< ulen
; i
++)
1772 scm_c_bitvector_set_x (v
, (size_t)indices
[i
], obj
);
1777 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1779 return SCM_UNSPECIFIED
;
1784 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1785 (SCM v
, SCM kv
, SCM obj
),
1786 "Return a count of how many entries in bit vector @var{v} are\n"
1787 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1790 "If @var{kv} is a bit vector, then those entries where it has\n"
1791 "@code{#t} are the ones in @var{v} which are considered.\n"
1792 "@var{kv} and @var{v} must be the same length.\n"
1794 "If @var{kv} is a u32vector, then it contains\n"
1795 "the indexes in @var{v} to consider.\n"
1800 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1801 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
1803 #define FUNC_NAME s_scm_bit_count_star
1805 if (scm_is_bitvector (kv
))
1807 size_t bit_len
= scm_c_bitvector_length (kv
);
1808 size_t word_len
= (bit_len
+ 31) / 32;
1809 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1810 scm_t_uint32 xor_mask
= scm_to_bool (obj
)? 0 : ((scm_t_uint32
)-1);
1811 const scm_t_uint32
*bits1
, *bits2
;
1812 size_t count
= 0, i
;
1814 if (scm_c_bitvector_length (v
) != bit_len
)
1815 scm_misc_error (NULL
,
1816 "bit vectors must have equal length",
1820 return scm_from_size_t (0);
1822 bits1
= scm_bitvector_elements (v
);
1823 bits2
= scm_bitvector_elements (kv
);
1825 for (i
= 0; i
< word_len
-1; i
++)
1826 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
]);
1827 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
] & last_mask
);
1829 scm_bitvector_release_elements (kv
);
1830 scm_bitvector_release_elements (v
);
1832 return scm_from_size_t (count
);
1834 else if (scm_is_true (scm_u32vector_p (kv
)))
1836 size_t count
= 0, ulen
, i
;
1837 const scm_t_uint32
*indices
;
1838 int bit
= scm_to_bool (obj
);
1840 scm_frame_begin (0);
1842 ulen
= scm_c_uniform_vector_length (kv
);
1843 indices
= scm_u32vector_elements (kv
);
1844 scm_frame_uniform_vector_release_elements (kv
);
1846 for (i
= 0; i
< ulen
; i
++)
1847 if ((scm_is_true (scm_c_bitvector_ref (v
, (size_t)indices
[i
])) != 0)
1853 return scm_from_size_t (count
);
1856 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1861 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1863 "Modify the bit vector @var{v} by replacing each element with\n"
1865 #define FUNC_NAME s_scm_bit_invert_x
1867 size_t bit_len
= scm_c_bitvector_length (v
);
1868 size_t word_len
= (bit_len
+ 31) / 32;
1869 scm_t_uint32
*bits
= scm_bitvector_writable_elements (v
);
1872 for (i
= 0; i
< word_len
; i
++)
1875 scm_bitvector_release_writable_elements (v
);
1876 return SCM_UNSPECIFIED
;
1882 scm_istr2bve (SCM str
)
1884 size_t len
= scm_i_string_length (str
);
1885 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
1890 const char *c_str
= scm_i_string_chars (str
);
1891 scm_t_uint32
*data
= scm_bitvector_writable_elements (vec
);
1893 for (k
= 0; k
< (len
+ 31) / 32; k
++)
1899 for (mask
= 1L; j
--; mask
<<= 1)
1914 scm_remember_upto_here_1 (str
);
1915 scm_bitvector_release_writable_elements (vec
);
1922 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
1925 long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1927 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
1929 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
1931 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
1932 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1937 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
1945 res
= scm_cons (scm_i_cvref (SCM_ARRAY_V (ra
), i
, enclosed
),
1953 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
1955 "Return a list consisting of all the elements, in order, of\n"
1957 #define FUNC_NAME s_scm_array_to_list
1959 if (scm_is_generalized_vector (v
))
1960 return scm_generalized_vector_to_list (v
);
1961 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1962 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
1964 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1969 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
1971 SCM_DEFINE (scm_list_to_typed_array
, "list->typed-array", 3, 0, 0,
1972 (SCM type
, SCM ndim
, SCM lst
),
1973 "Return an array of the type @var{type}\n"
1974 "with elements the same as those of @var{lst}.\n"
1976 "The argument @var{ndim} determines the number of dimensions\n"
1977 "of the array. It is either an exact integer, giving the\n"
1978 "number directly, or a list of exact integers, whose length\n"
1979 "specifies the number of dimensions and each element is the\n"
1980 "lower index bound of its dimension.")
1981 #define FUNC_NAME s_scm_list_to_typed_array
1989 if (scm_is_integer (ndim
))
1991 size_t k
= scm_to_size_t (ndim
);
1994 shape
= scm_cons (scm_length (row
), shape
);
1996 row
= scm_car (row
);
2003 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
2004 scm_sum (scm_sum (scm_car (ndim
),
2006 scm_from_int (-1))),
2008 ndim
= scm_cdr (ndim
);
2009 if (scm_is_pair (ndim
))
2010 row
= scm_car (row
);
2016 ra
= scm_make_typed_array (type
, SCM_BOOL_F
, scm_reverse_x (shape
, SCM_EOL
));
2018 if (scm_is_null (shape
))
2020 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2021 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2024 if (!SCM_ARRAYP (ra
))
2026 size_t length
= scm_c_generalized_vector_length (ra
);
2027 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2028 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
2031 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2034 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2039 SCM_DEFINE (scm_list_to_array
, "list->array", 2, 0, 0,
2040 (SCM ndim
, SCM lst
),
2041 "Return an array with elements the same as those of @var{lst}.")
2042 #define FUNC_NAME s_scm_list_to_array
2044 return scm_list_to_typed_array (SCM_BOOL_T
, ndim
, lst
);
2049 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2051 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2052 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2055 return (scm_is_null (lst
));
2056 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2060 if (!scm_is_pair (lst
))
2062 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2064 lst
= SCM_CDR (lst
);
2066 if (!scm_is_null (lst
))
2073 if (!scm_is_pair (lst
))
2075 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
2077 lst
= SCM_CDR (lst
);
2079 if (!scm_is_null (lst
))
2085 #if SCM_ENABLE_DEPRECATED
2087 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2088 (SCM ndim
, SCM prot
, SCM lst
),
2089 "Return a uniform array of the type indicated by prototype\n"
2090 "@var{prot} with elements the same as those of @var{lst}.\n"
2091 "Elements must be of the appropriate type, no coercions are\n"
2094 "The argument @var{ndim} determines the number of dimensions\n"
2095 "of the array. It is either an exact integer, giving the\n"
2096 "number directly, or a list of exact integers, whose length\n"
2097 "specifies the number of dimensions and each element is the\n"
2098 "lower index bound of its dimension.")
2099 #define FUNC_NAME s_scm_list_to_uniform_array
2101 return scm_list_to_typed_array (prototype_to_type (prot
), ndim
, lst
);
2107 /* Print dimension DIM of ARRAY.
2111 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
2112 SCM port
, scm_print_state
*pstate
)
2114 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
2117 scm_putc ('(', port
);
2119 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2121 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2122 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2125 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
2127 if (idx
< dim_spec
->ubnd
)
2128 scm_putc (' ', port
);
2129 base
+= dim_spec
->inc
;
2132 scm_putc (')', port
);
2136 /* Print an array. (Only for strict arrays, not for generalized vectors.)
2140 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2142 long ndim
= SCM_ARRAY_NDIM (array
);
2143 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2144 SCM v
= SCM_ARRAY_V (array
);
2145 unsigned long base
= SCM_ARRAY_BASE (array
);
2148 scm_putc ('#', port
);
2149 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2150 scm_intprint (ndim
, 10, port
);
2151 if (scm_is_uniform_vector (v
))
2152 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2153 else if (scm_is_bitvector (v
))
2154 scm_puts ("b", port
);
2155 else if (scm_is_string (v
))
2156 scm_puts ("a", port
);
2157 else if (!scm_is_vector (v
))
2158 scm_puts ("?", port
);
2160 for (i
= 0; i
< ndim
; i
++)
2161 if (dim_specs
[i
].lbnd
!= 0)
2163 for (i
= 0; i
< ndim
; i
++)
2165 scm_putc ('@', port
);
2166 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2171 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2175 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2179 scm_putc ('#', port
);
2180 base
= SCM_ARRAY_BASE (array
);
2181 scm_puts ("<enclosed-array ", port
);
2182 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2183 scm_putc ('>', port
);
2187 /* Read an array. This function can also read vectors and uniform
2188 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2191 C is the first character read after the '#'.
2195 tag_to_type (const char *tag
, SCM port
)
2197 #if SCM_ENABLE_DEPRECATED
2199 /* Recognize the old syntax.
2201 const char *instead
;
2233 if (instead
&& tag
[1] == '\0')
2235 scm_c_issue_deprecation_warning_fmt
2236 ("The tag '%c' is deprecated for uniform vectors. "
2237 "Use '%s' instead.", tag
[0], instead
);
2238 return scm_from_locale_symbol (instead
);
2243 return scm_from_locale_symbol (tag
);
2247 scm_i_read_array (SCM port
, int c
)
2254 SCM lower_bounds
, elements
;
2256 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2257 the array code can not deal with zero-length dimensions yet, and
2258 we want to allow zero-length vectors, of course.
2262 scm_ungetc (c
, port
);
2263 return scm_vector (scm_read (port
));
2266 /* Disambiguate between '#f' and uniform floating point vectors.
2270 c
= scm_getc (port
);
2271 if (c
!= '3' && c
!= '6')
2274 scm_ungetc (c
, port
);
2281 goto continue_reading_tag
;
2284 /* Read rank. We disallow arrays of rank zero since they do not
2285 seem to work reliably yet. */
2288 while ('0' <= c
&& c
<= '9')
2290 rank
= 10*rank
+ c
-'0';
2292 c
= scm_getc (port
);
2297 scm_i_input_error (NULL
, port
,
2298 "array rank must be positive", SCM_EOL
);
2302 continue_reading_tag
:
2303 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2306 c
= scm_getc (port
);
2308 tag
[tag_len
] = '\0';
2310 /* Read lower bounds. */
2311 lower_bounds
= SCM_EOL
;
2314 /* Yeah, right, we should use some ready-made integer parsing
2321 c
= scm_getc (port
);
2325 c
= scm_getc (port
);
2327 while ('0' <= c
&& c
<= '9')
2329 lbnd
= 10*lbnd
+ c
-'0';
2330 c
= scm_getc (port
);
2332 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2335 /* Read nested lists of elements.
2338 scm_i_input_error (NULL
, port
,
2339 "missing '(' in vector or array literal",
2341 scm_ungetc (c
, port
);
2342 elements
= scm_read (port
);
2344 if (scm_is_null (lower_bounds
))
2345 lower_bounds
= scm_from_size_t (rank
);
2346 else if (scm_ilength (lower_bounds
) != rank
)
2347 scm_i_input_error (NULL
, port
,
2348 "the number of lower bounds must match the array rank",
2351 /* Construct array. */
2352 return scm_list_to_typed_array (tag_to_type (tag
, port
),
2358 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2360 scm_iprin1 (exp
, port
, pstate
);
2364 SCM_DEFINE (scm_array_type
, "array-type", 1, 0, 0,
2367 #define FUNC_NAME s_scm_array_type
2369 if (SCM_ARRAYP (ra
))
2370 return scm_i_generalized_vector_type (SCM_ARRAY_V (ra
));
2371 else if (scm_is_generalized_vector (ra
))
2372 return scm_i_generalized_vector_type (ra
);
2373 else if (SCM_ENCLOSED_ARRAYP (ra
))
2374 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2376 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2380 #if SCM_ENABLE_DEPRECATED
2382 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2384 "Return an object that would produce an array of the same type\n"
2385 "as @var{array}, if used as the @var{prototype} for\n"
2386 "@code{make-uniform-array}.")
2387 #define FUNC_NAME s_scm_array_prototype
2389 if (SCM_ARRAYP (ra
))
2390 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2391 else if (scm_is_generalized_vector (ra
))
2392 return scm_i_get_old_prototype (ra
);
2393 else if (SCM_ENCLOSED_ARRAYP (ra
))
2394 return SCM_UNSPECIFIED
;
2396 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2403 array_mark (SCM ptr
)
2405 return SCM_ARRAY_V (ptr
);
2409 array_free (SCM ptr
)
2411 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2412 (sizeof (scm_t_array
)
2413 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2421 scm_tc16_array
= scm_make_smob_type ("array", 0);
2422 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2423 scm_set_smob_free (scm_tc16_array
, array_free
);
2424 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2425 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2427 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2428 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2429 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2430 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2431 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2433 scm_add_feature ("array");
2435 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2436 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2437 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2438 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2440 init_type_creator_table ();
2442 #include "libguile/unif.x"