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 SCM scm_i_proc_make_vector
;
86 SCM scm_i_proc_make_string
;
87 SCM scm_i_proc_make_bitvector
;
89 #if SCM_ENABLE_DEPRECATED
91 SCM_SYMBOL (scm_sym_s
, "s");
92 SCM_SYMBOL (scm_sym_l
, "l");
95 scm_i_convert_old_prototype (SCM proto
)
99 /* All new 'prototypes' are creator procedures.
101 if (scm_is_true (scm_procedure_p (proto
)))
104 if (scm_is_eq (proto
, SCM_BOOL_T
))
105 new_proto
= scm_i_proc_make_bitvector
;
106 else if (scm_is_eq (proto
, SCM_MAKE_CHAR ('a')))
107 new_proto
= scm_i_proc_make_string
;
108 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
109 new_proto
= scm_i_proc_make_s8vector
;
110 else if (scm_is_eq (proto
, scm_sym_s
))
111 new_proto
= scm_i_proc_make_s16vector
;
112 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (1))))
113 new_proto
= scm_i_proc_make_u32vector
;
114 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (-1))))
115 new_proto
= scm_i_proc_make_s32vector
;
116 else if (scm_is_eq (proto
, scm_sym_l
))
117 new_proto
= scm_i_proc_make_s64vector
;
118 else if (scm_is_true (scm_eqv_p (proto
, scm_from_double (1.0))))
119 new_proto
= scm_i_proc_make_f32vector
;
120 else if (scm_is_true (scm_eqv_p (proto
, scm_divide (scm_from_int (1),
122 new_proto
= scm_i_proc_make_f64vector
;
123 else if (scm_is_true (scm_eqv_p (proto
, scm_c_make_rectangular (0, 1))))
124 new_proto
= scm_i_proc_make_c64vector
;
125 else if (scm_is_null (proto
))
126 new_proto
= scm_i_proc_make_vector
;
130 scm_c_issue_deprecation_warning
131 ("Using prototypes with arrays is deprecated. "
132 "Use creator functions instead.");
138 scm_i_get_old_prototype (SCM uvec
)
140 if (scm_is_bitvector (uvec
))
142 else if (scm_is_string (uvec
))
143 return SCM_MAKE_CHAR ('a');
144 else if (scm_is_true (scm_s8vector_p (uvec
)))
145 return SCM_MAKE_CHAR ('\0');
146 else if (scm_is_true (scm_s16vector_p (uvec
)))
148 else if (scm_is_true (scm_u32vector_p (uvec
)))
149 return scm_from_int (1);
150 else if (scm_is_true (scm_s32vector_p (uvec
)))
151 return scm_from_int (-1);
152 else if (scm_is_true (scm_s64vector_p (uvec
)))
154 else if (scm_is_true (scm_f32vector_p (uvec
)))
155 return scm_from_double (1.0);
156 else if (scm_is_true (scm_f64vector_p (uvec
)))
157 return scm_divide (scm_from_int (1), scm_from_int (3));
158 else if (scm_is_true (scm_c64vector_p (uvec
)))
159 return scm_c_make_rectangular (0, 1);
160 else if (scm_is_vector (uvec
))
163 scm_misc_error (NULL
, "~a has no prototype", scm_list_1 (uvec
));
169 scm_make_uve (long k
, SCM prot
)
170 #define FUNC_NAME "scm_make_uve"
173 #if SCM_ENABLE_DEPRECATED
174 prot
= scm_i_convert_old_prototype (prot
);
176 res
= scm_call_1 (prot
, scm_from_long (k
));
177 if (!scm_is_generalized_vector (res
))
178 scm_wrong_type_arg_msg (NULL
, 0, res
, "generalized vector");
183 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
185 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
186 "not. The @var{prototype} argument is used with uniform arrays\n"
187 "and is described elsewhere.")
188 #define FUNC_NAME s_scm_array_p
190 if (SCM_ENCLOSED_ARRAYP (v
))
192 /* Enclosed arrays are arrays but are not created by any known
195 if (SCM_UNBNDP (prot
))
201 /* Get storage vector.
206 /* It must be a generalized vector (which includes vectors, strings, etc).
208 if (!scm_is_generalized_vector (v
))
211 if (SCM_UNBNDP (prot
))
214 #if SCM_ENABLE_DEPRECATED
215 prot
= scm_i_convert_old_prototype (prot
);
217 return scm_eq_p (prot
, scm_i_generalized_vector_creator (v
));
222 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
224 "Return the number of dimensions of the array @var{array.}\n")
225 #define FUNC_NAME s_scm_array_rank
227 if (scm_is_generalized_vector (array
))
228 return scm_from_int (1);
230 if (SCM_ARRAYP (array
) || SCM_ENCLOSED_ARRAYP (array
))
231 return scm_from_size_t (SCM_ARRAY_NDIM (array
));
233 scm_wrong_type_arg_msg (NULL
, 0, array
, "array");
238 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
240 "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
241 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
243 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
245 #define FUNC_NAME s_scm_array_dimensions
247 if (scm_is_generalized_vector (ra
))
248 return scm_cons (scm_generalized_vector_length (ra
), SCM_EOL
);
250 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
256 k
= SCM_ARRAY_NDIM (ra
);
257 s
= SCM_ARRAY_DIMS (ra
);
259 res
= scm_cons (s
[k
].lbnd
260 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
261 scm_from_long (s
[k
].ubnd
),
263 : scm_from_long (1 + s
[k
].ubnd
),
268 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
273 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
275 "Return the root vector of a shared array.")
276 #define FUNC_NAME s_scm_shared_array_root
278 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
279 SCM_ARG1
, FUNC_NAME
);
280 return SCM_ARRAY_V (ra
);
285 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
287 "Return the root vector index of the first element in the array.")
288 #define FUNC_NAME s_scm_shared_array_offset
290 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
291 SCM_ARG1
, FUNC_NAME
);
292 return scm_from_int (SCM_ARRAY_BASE (ra
));
297 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
299 "For each dimension, return the distance between elements in the root vector.")
300 #define FUNC_NAME s_scm_shared_array_increments
306 SCM_ASSERT (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
), ra
,
307 SCM_ARG1
, FUNC_NAME
);
308 k
= SCM_ARRAY_NDIM (ra
);
309 s
= SCM_ARRAY_DIMS (ra
);
311 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
317 static char s_bad_ind
[] = "Bad scm_array index";
321 scm_aind (SCM ra
, SCM args
, const char *what
)
325 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
326 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
327 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
329 if (scm_is_integer (args
))
332 scm_error_num_args_subr (what
);
333 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
335 while (k
&& scm_is_pair (args
))
337 ind
= SCM_CAR (args
);
338 args
= SCM_CDR (args
);
339 if (!scm_is_integer (ind
))
340 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
341 j
= scm_to_long (ind
);
342 if (j
< s
->lbnd
|| j
> s
->ubnd
)
343 scm_out_of_range (what
, ind
);
344 pos
+= (j
- s
->lbnd
) * (s
->inc
);
348 if (k
!= 0 || !scm_is_null (args
))
349 scm_error_num_args_subr (what
);
356 scm_i_make_ra (int ndim
, scm_t_bits tag
)
359 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + tag
,
360 scm_gc_malloc ((sizeof (scm_t_array
) +
361 ndim
* sizeof (scm_t_array_dim
)),
363 SCM_ARRAY_V (ra
) = SCM_BOOL_F
;
368 scm_make_ra (int ndim
)
370 return scm_i_make_ra (ndim
, scm_tc16_array
);
374 static char s_bad_spec
[] = "Bad scm_array dimension";
377 /* Increments will still need to be set. */
380 scm_shap2ra (SCM args
, const char *what
)
384 int ndim
= scm_ilength (args
);
386 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
388 ra
= scm_make_ra (ndim
);
389 SCM_ARRAY_BASE (ra
) = 0;
390 s
= SCM_ARRAY_DIMS (ra
);
391 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
393 spec
= SCM_CAR (args
);
394 if (scm_is_integer (spec
))
396 if (scm_to_long (spec
) < 0)
397 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
399 s
->ubnd
= scm_to_long (spec
) - 1;
404 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
405 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
406 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
408 if (!scm_is_pair (sp
)
409 || !scm_is_integer (SCM_CAR (sp
))
410 || !scm_is_null (SCM_CDR (sp
)))
411 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
412 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
419 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
420 (SCM dims
, SCM prot
, SCM fill
),
421 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
422 "Create and return a uniform array or vector of type\n"
423 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
424 "length @var{length}. If @var{fill} is supplied, it's used to\n"
425 "fill the array, otherwise @var{prototype} is used.")
426 #define FUNC_NAME s_scm_dimensions_to_uniform_array
429 unsigned long rlen
= 1;
433 if (scm_is_integer (dims
))
435 SCM answer
= scm_make_uve (scm_to_long (dims
), prot
);
436 if (!SCM_UNBNDP (fill
))
437 scm_array_fill_x (answer
, fill
);
438 else if (scm_is_symbol (prot
) || scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
439 scm_array_fill_x (answer
, scm_from_int (0));
440 else if (scm_is_false (scm_procedure_p (prot
)))
441 scm_array_fill_x (answer
, prot
);
445 SCM_ASSERT (scm_is_null (dims
) || scm_is_pair (dims
),
446 dims
, SCM_ARG1
, FUNC_NAME
);
447 ra
= scm_shap2ra (dims
, FUNC_NAME
);
448 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
449 s
= SCM_ARRAY_DIMS (ra
);
450 k
= SCM_ARRAY_NDIM (ra
);
455 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
456 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
459 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
461 if (!SCM_UNBNDP (fill
))
462 scm_array_fill_x (ra
, fill
);
463 else if (scm_is_symbol (prot
) || scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
464 scm_array_fill_x (ra
, scm_from_int (0));
465 else if (scm_is_false (scm_procedure_p (prot
)))
466 scm_array_fill_x (ra
, prot
);
468 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
469 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
470 return SCM_ARRAY_V (ra
);
477 scm_ra_set_contp (SCM ra
)
479 /* XXX - correct? one-dimensional arrays are always 'contiguous',
482 size_t k
= SCM_ARRAY_NDIM (ra
);
485 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
488 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
490 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
493 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
494 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
497 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
501 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
502 (SCM oldra
, SCM mapfunc
, SCM dims
),
503 "@code{make-shared-array} can be used to create shared subarrays of other\n"
504 "arrays. The @var{mapper} is a function that translates coordinates in\n"
505 "the new array into coordinates in the old array. A @var{mapper} must be\n"
506 "linear, and its range must stay within the bounds of the old array, but\n"
507 "it can be otherwise arbitrary. A simple example:\n"
509 "(define fred (make-array #f 8 8))\n"
510 "(define freds-diagonal\n"
511 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
512 "(array-set! freds-diagonal 'foo 3)\n"
513 "(array-ref fred 3 3) @result{} foo\n"
514 "(define freds-center\n"
515 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
516 "(array-ref freds-center 0 0) @result{} foo\n"
518 #define FUNC_NAME s_scm_make_shared_array
524 long old_min
, new_min
, old_max
, new_max
;
527 SCM_VALIDATE_REST_ARGUMENT (dims
);
528 SCM_VALIDATE_ARRAY (1, oldra
);
529 SCM_VALIDATE_PROC (2, mapfunc
);
530 ra
= scm_shap2ra (dims
, FUNC_NAME
);
531 if (SCM_ARRAYP (oldra
))
533 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
534 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
535 s
= SCM_ARRAY_DIMS (oldra
);
536 k
= SCM_ARRAY_NDIM (oldra
);
540 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
542 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
547 SCM_ARRAY_V (ra
) = oldra
;
549 old_max
= scm_c_generalized_vector_length (oldra
) - 1;
552 s
= SCM_ARRAY_DIMS (ra
);
553 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
555 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
556 if (s
[k
].ubnd
< s
[k
].lbnd
)
558 if (1 == SCM_ARRAY_NDIM (ra
))
559 ra
= scm_make_uve (0L, scm_array_creator (ra
));
561 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_creator (ra
));
565 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
566 if (SCM_ARRAYP (oldra
))
567 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
570 if (!scm_is_integer (imap
))
572 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
573 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
574 imap
= SCM_CAR (imap
);
576 i
= scm_to_size_t (imap
);
578 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
580 k
= SCM_ARRAY_NDIM (ra
);
583 if (s
[k
].ubnd
> s
[k
].lbnd
)
585 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
586 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
587 if (SCM_ARRAYP (oldra
))
589 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
592 if (!scm_is_integer (imap
))
594 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
595 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
596 imap
= SCM_CAR (imap
);
598 s
[k
].inc
= scm_to_long (imap
) - i
;
602 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
604 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
607 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
608 indptr
= SCM_CDR (indptr
);
610 if (old_min
> new_min
|| old_max
< new_max
)
611 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
612 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
614 SCM v
= SCM_ARRAY_V (ra
);
615 unsigned long int length
= scm_to_ulong (scm_uniform_vector_length (v
));
616 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
618 if (s
->ubnd
< s
->lbnd
)
619 return scm_make_uve (0L, scm_array_creator (ra
));
621 scm_ra_set_contp (ra
);
627 /* args are RA . DIMS */
628 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
630 "Return an array sharing contents with @var{array}, but with\n"
631 "dimensions arranged in a different order. There must be one\n"
632 "@var{dim} argument for each dimension of @var{array}.\n"
633 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
634 "and the rank of the array to be returned. Each integer in that\n"
635 "range must appear at least once in the argument list.\n"
637 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
638 "dimensions in the array to be returned, their positions in the\n"
639 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
640 "may have the same value, in which case the returned array will\n"
641 "have smaller rank than @var{array}.\n"
644 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
645 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
646 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
647 " #2((a 4) (b 5) (c 6))\n"
649 #define FUNC_NAME s_scm_transpose_array
652 SCM
const *ve
= &vargs
;
653 scm_t_array_dim
*s
, *r
;
656 SCM_VALIDATE_REST_ARGUMENT (args
);
657 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
659 if (scm_is_generalized_vector (ra
))
661 /* Make sure that we are called with a single zero as
664 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
665 SCM_WRONG_NUM_ARGS ();
666 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
667 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
671 if (SCM_ARRAYP (ra
) || SCM_ENCLOSED_ARRAYP (ra
))
673 vargs
= scm_vector (args
);
674 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
675 SCM_WRONG_NUM_ARGS ();
676 ve
= SCM_VELTS (vargs
);
678 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
680 i
= scm_to_signed_integer (ve
[k
], 0, SCM_ARRAY_NDIM(ra
));
685 res
= scm_make_ra (ndim
);
686 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
687 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
690 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
691 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
693 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
695 i
= scm_to_int (ve
[k
]);
696 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
697 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
698 if (r
->ubnd
< r
->lbnd
)
707 if (r
->ubnd
> s
->ubnd
)
709 if (r
->lbnd
< s
->lbnd
)
711 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
718 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
719 scm_ra_set_contp (res
);
723 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
727 /* args are RA . AXES */
728 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
730 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
731 "the rank of @var{array}. @var{enclose-array} returns an array\n"
732 "resembling an array of shared arrays. The dimensions of each shared\n"
733 "array are the same as the @var{dim}th dimensions of the original array,\n"
734 "the dimensions of the outer array are the same as those of the original\n"
735 "array that did not match a @var{dim}.\n\n"
736 "An enclosed array is not a general Scheme array. Its elements may not\n"
737 "be set using @code{array-set!}. Two references to the same element of\n"
738 "an enclosed array will be @code{equal?} but will not in general be\n"
739 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
740 "enclosed array is unspecified.\n\n"
743 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
744 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
745 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
746 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
748 #define FUNC_NAME s_scm_enclose_array
750 SCM axv
, res
, ra_inr
;
752 scm_t_array_dim vdim
, *s
= &vdim
;
753 int ndim
, j
, k
, ninr
, noutr
;
755 SCM_VALIDATE_REST_ARGUMENT (axes
);
756 if (scm_is_null (axes
))
757 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
758 ninr
= scm_ilength (axes
);
760 SCM_WRONG_NUM_ARGS ();
761 ra_inr
= scm_make_ra (ninr
);
763 if (scm_is_generalized_vector (ra
))
766 s
->ubnd
= scm_to_long (scm_uniform_vector_length (ra
)) - 1;
768 SCM_ARRAY_V (ra_inr
) = ra
;
769 SCM_ARRAY_BASE (ra_inr
) = 0;
772 else if (SCM_ARRAYP (ra
))
774 s
= SCM_ARRAY_DIMS (ra
);
775 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
776 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
777 ndim
= SCM_ARRAY_NDIM (ra
);
780 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
784 SCM_WRONG_NUM_ARGS ();
785 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
786 res
= scm_i_make_ra (noutr
, scm_tc16_enclosed_array
);
787 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
788 SCM_ARRAY_V (res
) = ra_inr
;
789 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
791 if (!scm_is_integer (SCM_CAR (axes
)))
792 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
793 j
= scm_to_int (SCM_CAR (axes
));
794 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
795 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
796 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
797 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
799 c_axv
= scm_i_string_chars (axv
);
800 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
804 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
805 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
806 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
808 scm_remember_upto_here_1 (axv
);
809 scm_ra_set_contp (ra_inr
);
810 scm_ra_set_contp (res
);
817 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
819 "Return @code{#t} if its arguments would be acceptable to\n"
821 #define FUNC_NAME s_scm_array_in_bounds_p
823 SCM res
= SCM_BOOL_T
;
825 SCM_VALIDATE_REST_ARGUMENT (args
);
827 if (scm_is_generalized_vector (v
))
831 if (!scm_is_pair (args
))
832 SCM_WRONG_NUM_ARGS ();
833 ind
= scm_to_long (SCM_CAR (args
));
834 args
= SCM_CDR (args
);
835 res
= scm_from_bool (ind
>= 0
836 && ind
< scm_c_generalized_vector_length (v
));
838 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
840 size_t k
= SCM_ARRAY_NDIM (v
);
841 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (v
);
847 if (!scm_is_pair (args
))
848 SCM_WRONG_NUM_ARGS ();
849 ind
= scm_to_long (SCM_CAR (args
));
850 args
= SCM_CDR (args
);
853 if (ind
< s
->lbnd
|| ind
> s
->ubnd
)
856 /* We do not stop the checking after finding a violation
857 since we want to validate the type-correctness and
858 number of arguments in any case.
864 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
866 if (!scm_is_null (args
))
867 SCM_WRONG_NUM_ARGS ();
874 scm_i_cvref (SCM v
, size_t pos
, int enclosed
)
878 int k
= SCM_ARRAY_NDIM (v
);
879 SCM res
= scm_make_ra (k
);
880 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
881 SCM_ARRAY_BASE (res
) = pos
;
884 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
885 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
886 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
891 return scm_c_generalized_vector_ref (v
, pos
);
895 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
897 return scm_i_cvref (v
, pos
, 0);
900 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
902 "Return the element at the @code{(index1, index2)} element in\n"
904 #define FUNC_NAME s_scm_array_ref
909 if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
911 enclosed
= SCM_ENCLOSED_ARRAYP (v
);
912 pos
= scm_aind (v
, args
, FUNC_NAME
);
920 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
921 pos
= scm_to_long (SCM_CAR (args
));
922 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
925 pos
= scm_to_long (args
);
926 length
= scm_c_generalized_vector_length (v
);
927 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
930 return scm_i_cvref (v
, pos
, enclosed
);
933 scm_wrong_num_args (NULL
);
935 scm_out_of_range (NULL
, scm_from_long (pos
));
940 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
941 (SCM v
, SCM obj
, SCM args
),
942 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
943 "@var{new-value}. The value returned by array-set! is unspecified.")
944 #define FUNC_NAME s_scm_array_set_x
950 pos
= scm_aind (v
, args
, FUNC_NAME
);
953 else if (SCM_ENCLOSED_ARRAYP (v
))
954 scm_wrong_type_arg_msg (NULL
, 0, v
, "non-enclosed array");
955 else if (scm_is_generalized_vector (v
))
958 if (scm_is_pair (args
))
960 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
961 pos
= scm_to_long (SCM_CAR (args
));
964 pos
= scm_to_long (args
);
965 length
= scm_c_generalized_vector_length (v
);
966 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
969 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
971 scm_c_generalized_vector_set_x (v
, pos
, obj
);
972 return SCM_UNSPECIFIED
;
975 scm_out_of_range (NULL
, scm_from_long (pos
));
977 scm_wrong_num_args (NULL
);
981 /* attempts to unroll an array into a one-dimensional array.
982 returns the unrolled array or #f if it can't be done. */
983 /* if strict is not SCM_UNDEFINED, return #f if returned array
984 wouldn't have contiguous elements. */
985 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
986 (SCM ra
, SCM strict
),
987 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
988 "without changing their order (last subscript changing fastest), then\n"
989 "@code{array-contents} returns that shared array, otherwise it returns\n"
990 "@code{#f}. All arrays made by @var{make-array} and\n"
991 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
992 "@var{make-shared-array} may not be.\n\n"
993 "If the optional argument @var{strict} is provided, a shared array will\n"
994 "be returned only if its elements are stored internally contiguous in\n"
996 #define FUNC_NAME s_scm_array_contents
1000 if (scm_is_generalized_vector (ra
))
1003 if (SCM_ARRAYP (ra
))
1005 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1006 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1008 for (k
= 0; k
< ndim
; k
++)
1009 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1010 if (!SCM_UNBNDP (strict
))
1012 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1014 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1016 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1017 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1024 SCM v
= SCM_ARRAY_V (ra
);
1025 size_t length
= scm_c_generalized_vector_length (v
);
1026 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1030 sra
= scm_make_ra (1);
1031 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1032 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1033 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1034 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1035 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1038 else if (SCM_ENCLOSED_ARRAYP (ra
))
1039 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
1041 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1047 scm_ra2contig (SCM ra
, int copy
)
1052 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1053 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1054 k
= SCM_ARRAY_NDIM (ra
);
1055 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1057 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1059 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1060 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1061 0 == len
% SCM_LONG_BIT
))
1064 ret
= scm_make_ra (k
);
1065 SCM_ARRAY_BASE (ret
) = 0;
1068 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1069 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1070 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1071 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1073 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_creator (ra
));
1075 scm_array_copy_x (ra
, ret
);
1081 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1082 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1083 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1084 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1085 "binary objects from @var{port-or-fdes}.\n"
1086 "If an end of file is encountered,\n"
1087 "the objects up to that point are put into @var{ura}\n"
1088 "(starting at the beginning) and the remainder of the array is\n"
1090 "The optional arguments @var{start} and @var{end} allow\n"
1091 "a specified region of a vector (or linearized array) to be read,\n"
1092 "leaving the remainder of the vector unchanged.\n\n"
1093 "@code{uniform-array-read!} returns the number of objects read.\n"
1094 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1095 "returned by @code{(current-input-port)}.")
1096 #define FUNC_NAME s_scm_uniform_array_read_x
1098 if (SCM_UNBNDP (port_or_fd
))
1099 port_or_fd
= scm_cur_inp
;
1101 if (scm_is_uniform_vector (ura
))
1103 return scm_uniform_vector_read_x (ura
, port_or_fd
, start
, end
);
1105 else if (SCM_ARRAYP (ura
))
1107 size_t base
, vlen
, cstart
, cend
;
1110 cra
= scm_ra2contig (ura
, 0);
1111 base
= SCM_ARRAY_BASE (cra
);
1112 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1113 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1117 if (!SCM_UNBNDP (start
))
1119 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1120 if (!SCM_UNBNDP (end
))
1121 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1124 ans
= scm_uniform_vector_read_x (SCM_ARRAY_V (cra
), port_or_fd
,
1125 scm_from_size_t (base
+ cstart
),
1126 scm_from_size_t (base
+ cend
));
1128 if (!scm_is_eq (cra
, ura
))
1129 scm_array_copy_x (cra
, ura
);
1132 else if (SCM_ENCLOSED_ARRAYP (ura
))
1133 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1135 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1139 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1140 (SCM ura
, SCM port_or_fd
, SCM start
, SCM end
),
1141 "Writes all elements of @var{ura} as binary objects to\n"
1142 "@var{port-or-fdes}.\n\n"
1143 "The optional arguments @var{start}\n"
1144 "and @var{end} allow\n"
1145 "a specified region of a vector (or linearized array) to be written.\n\n"
1146 "The number of objects actually written is returned.\n"
1147 "@var{port-or-fdes} may be\n"
1148 "omitted, in which case it defaults to the value returned by\n"
1149 "@code{(current-output-port)}.")
1150 #define FUNC_NAME s_scm_uniform_array_write
1152 if (SCM_UNBNDP (port_or_fd
))
1153 port_or_fd
= scm_cur_outp
;
1155 if (scm_is_uniform_vector (ura
))
1157 return scm_uniform_vector_write (ura
, port_or_fd
, start
, end
);
1159 else if (SCM_ARRAYP (ura
))
1161 size_t base
, vlen
, cstart
, cend
;
1164 cra
= scm_ra2contig (ura
, 1);
1165 base
= SCM_ARRAY_BASE (cra
);
1166 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1167 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1171 if (!SCM_UNBNDP (start
))
1173 cstart
= scm_to_unsigned_integer (start
, 0, vlen
);
1174 if (!SCM_UNBNDP (end
))
1175 cend
= scm_to_unsigned_integer (end
, cstart
, vlen
);
1178 ans
= scm_uniform_vector_write (SCM_ARRAY_V (cra
), port_or_fd
,
1179 scm_from_size_t (base
+ cstart
),
1180 scm_from_size_t (base
+ cend
));
1184 else if (SCM_ENCLOSED_ARRAYP (ura
))
1185 scm_wrong_type_arg_msg (NULL
, 0, ura
, "non-enclosed array");
1187 scm_wrong_type_arg_msg (NULL
, 0, ura
, "array");
1194 static scm_t_bits scm_tc16_bitvector
;
1196 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1197 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1198 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1201 bitvector_free (SCM vec
)
1203 scm_gc_free (BITVECTOR_BITS (vec
),
1204 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1210 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1212 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1213 size_t word_len
= (bit_len
+31)/32;
1214 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1217 scm_puts ("#*", port
);
1218 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1220 scm_t_uint32 mask
= 1;
1221 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1222 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1229 bitvector_equalp (SCM vec1
, SCM vec2
)
1231 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1232 size_t word_len
= (bit_len
+ 31) / 32;
1233 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1234 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1235 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1237 /* compare lengths */
1238 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1240 /* avoid underflow in word_len-1 below. */
1243 /* compare full words */
1244 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1246 /* compare partial last words */
1247 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1253 scm_is_bitvector (SCM vec
)
1255 return IS_BITVECTOR (vec
);
1258 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1260 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1261 "return @code{#f}.")
1262 #define FUNC_NAME s_scm_bitvector_p
1264 return scm_from_bool (scm_is_bitvector (obj
));
1269 scm_c_make_bitvector (size_t len
, SCM fill
)
1271 size_t word_len
= (len
+ 31) / 32;
1275 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1277 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1279 if (!SCM_UNBNDP (fill
))
1280 scm_bitvector_fill_x (res
, fill
);
1285 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1286 (SCM len
, SCM fill
),
1287 "Create a new bitvector of length @var{len} and\n"
1288 "optionally initialize all elements to @var{fill}.")
1289 #define FUNC_NAME s_scm_make_bitvector
1291 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1295 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1297 "Create a new bitvector with the arguments as elements.")
1298 #define FUNC_NAME s_scm_bitvector
1300 return scm_list_to_bitvector (bits
);
1305 scm_c_bitvector_length (SCM vec
)
1307 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1308 return BITVECTOR_LENGTH (vec
);
1311 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1313 "Return the length of the bitvector @var{vec}.")
1314 #define FUNC_NAME s_scm_bitvector_length
1316 return scm_from_size_t (scm_c_bitvector_length (vec
));
1320 const scm_t_uint32
*
1321 scm_bitvector_elements (SCM vec
)
1323 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1324 return BITVECTOR_BITS (vec
);
1328 scm_bitvector_release_elements (SCM vec
)
1330 /* Nothing to do right now, but this function might come in handy
1331 when bitvectors need to be locked when giving away a pointer
1334 Also, a call to scm_bitvector_release_elements acts like
1335 scm_remember_upto_here, which is needed in any case.
1338 scm_remember_upto_here_1 (vec
);
1342 scm_frame_bitvector_release_elements (SCM vec
)
1344 scm_frame_unwind_handler_with_scm (scm_bitvector_release_elements
, vec
,
1345 SCM_F_WIND_EXPLICITLY
);
1349 scm_bitvector_writable_elements (SCM vec
)
1351 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1352 return BITVECTOR_BITS (vec
);
1356 scm_bitvector_release_writable_elements (SCM vec
)
1358 scm_remember_upto_here_1 (vec
);
1362 scm_frame_bitvector_release_writable_elements (SCM vec
)
1364 scm_frame_unwind_handler_with_scm
1365 (scm_bitvector_release_writable_elements
, vec
,
1366 SCM_F_WIND_EXPLICITLY
);
1370 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1372 if (idx
< scm_c_bitvector_length (vec
))
1374 const scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1375 SCM res
= (bits
[idx
/32] & (1L << (idx
%32)))? SCM_BOOL_T
: SCM_BOOL_F
;
1376 scm_bitvector_release_elements (vec
);
1380 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1383 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1385 "Return the element at index @var{idx} of the bitvector\n"
1387 #define FUNC_NAME s_scm_bitvector_ref
1389 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1394 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1396 if (idx
< scm_c_bitvector_length (vec
))
1398 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1399 scm_t_uint32 mask
= 1L << (idx
%32);
1400 if (scm_is_true (val
))
1401 bits
[idx
/32] |= mask
;
1403 bits
[idx
/32] &= ~mask
;
1404 scm_bitvector_release_writable_elements (vec
);
1407 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1410 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1411 (SCM vec
, SCM idx
, SCM val
),
1412 "Set the element at index @var{idx} of the bitvector\n"
1413 "@var{vec} when @var{val} is true, else clear it.")
1414 #define FUNC_NAME s_scm_bitvector_set_x
1416 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1417 return SCM_UNSPECIFIED
;
1421 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1423 "Set all elements of the bitvector\n"
1424 "@var{vec} when @var{val} is true, else clear them.")
1425 #define FUNC_NAME s_scm_bitvector_fill_x
1427 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1428 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1429 size_t word_len
= (bit_len
+ 31) / 32;
1430 memset (bits
, scm_is_true (val
)? -1:0, sizeof (scm_t_uint32
) * word_len
);
1431 scm_bitvector_release_writable_elements (vec
);
1432 return SCM_UNSPECIFIED
;
1436 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1438 "Return a new bitvector initialized with the elements\n"
1440 #define FUNC_NAME s_scm_list_to_bitvector
1442 size_t bit_len
= scm_to_size_t (scm_length (list
));
1443 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1444 size_t word_len
= (bit_len
+31)/32;
1445 scm_t_uint32
*bits
= scm_bitvector_writable_elements (vec
);
1448 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1450 scm_t_uint32 mask
= 1;
1452 for (j
= 0; j
< 32 && j
< bit_len
;
1453 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1454 if (scm_is_true (SCM_CAR (list
)))
1458 scm_bitvector_release_writable_elements (vec
);
1463 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1465 "Return a new list initialized with the elements\n"
1466 "of the bitvector @var{vec}.")
1467 #define FUNC_NAME s_scm_bitvector_to_list
1469 size_t bit_len
= scm_c_bitvector_length (vec
);
1471 size_t word_len
= (bit_len
+31)/32;
1472 const scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1475 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1477 scm_t_uint32 mask
= 1;
1478 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1479 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1482 scm_bitvector_release_elements (vec
);
1483 return scm_reverse_x (res
, SCM_EOL
);
1487 /* From mmix-arith.w by Knuth.
1489 Here's a fun way to count the number of bits in a tetrabyte.
1491 [This classical trick is called the ``Gillies--Miller method for
1492 sideways addition'' in {\sl The Preparation of Programs for an
1493 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1494 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1495 the tricks used here were suggested by Balbir Singh, Peter
1496 Rossmanith, and Stefan Schwoon.]
1500 count_ones (scm_t_uint32 x
)
1502 x
=x
-((x
>>1)&0x55555555);
1503 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1504 x
=(x
+(x
>>4))&0x0f0f0f0f;
1506 return (x
+(x
>>16)) & 0xff;
1509 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1510 (SCM b
, SCM bitvector
),
1511 "Return the number of occurrences of the boolean @var{b} in\n"
1513 #define FUNC_NAME s_scm_bit_count
1515 size_t bit_len
= scm_c_bitvector_length (bitvector
);
1516 size_t word_len
= (bit_len
+ 31) / 32;
1517 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1518 const scm_t_uint32
*bits
= scm_bitvector_elements (bitvector
);
1520 int bit
= scm_to_bool (b
);
1521 size_t count
= 0, i
;
1526 for (i
= 0; i
< word_len
-1; i
++)
1527 count
+= count_ones (bits
[i
]);
1528 count
+= count_ones (bits
[i
] & last_mask
);
1530 scm_bitvector_release_elements (bitvector
);
1531 return scm_from_size_t (bit
? count
: bit_len
-count
);
1535 /* returns 32 for x == 0.
1538 find_first_one (scm_t_uint32 x
)
1541 /* do a binary search in x. */
1542 if ((x
& 0xFFFF) == 0)
1543 x
>>= 16, pos
+= 16;
1544 if ((x
& 0xFF) == 0)
1555 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1556 (SCM item
, SCM v
, SCM k
),
1557 "Return the index of the first occurrance of @var{item} in bit\n"
1558 "vector @var{v}, starting from @var{k}. If there is no\n"
1559 "@var{item} entry between @var{k} and the end of\n"
1560 "@var{bitvector}, then return @code{#f}. For example,\n"
1563 "(bit-position #t #*000101 0) @result{} 3\n"
1564 "(bit-position #f #*0001111 3) @result{} #f\n"
1566 #define FUNC_NAME s_scm_bit_position
1568 size_t bit_len
= scm_c_bitvector_length (v
);
1569 size_t word_len
= (bit_len
+ 31) / 32;
1570 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1571 const scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1572 size_t first_bit
= scm_to_unsigned_integer (k
, 0, bit_len
);
1573 size_t first_word
= first_bit
/ 32;
1574 scm_t_uint32 first_mask
= ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1577 int bit
= scm_to_bool (item
);
1579 SCM res
= SCM_BOOL_F
;
1584 for (i
= first_word
; i
< word_len
; i
++)
1586 w
= (bit
? bits
[i
] : ~bits
[i
]);
1587 if (i
== first_word
)
1589 if (i
== word_len
-1)
1593 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1598 scm_bitvector_release_elements (v
);
1603 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1604 (SCM v
, SCM kv
, SCM obj
),
1605 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1606 "selecting the entries to change. The return value is\n"
1609 "If @var{kv} is a bit vector, then those entries where it has\n"
1610 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1611 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1612 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1613 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1616 "(define bv #*01000010)\n"
1617 "(bit-set*! bv #*10010001 #t)\n"
1619 "@result{} #*11010011\n"
1622 "If @var{kv} is a u32vector, then its elements are\n"
1623 "indices into @var{v} which are set to @var{obj}.\n"
1626 "(define bv #*01000010)\n"
1627 "(bit-set*! bv #u32(5 2 7) #t)\n"
1629 "@result{} #*01100111\n"
1631 #define FUNC_NAME s_scm_bit_set_star_x
1633 if (scm_is_bitvector (kv
))
1635 size_t bit_len
= scm_c_bitvector_length (kv
);
1636 size_t word_len
= (bit_len
+ 31) / 32;
1637 scm_t_uint32
*bits1
;
1638 const scm_t_uint32
*bits2
;
1640 int bit
= scm_to_bool (obj
);
1642 if (scm_c_bitvector_length (v
) != bit_len
)
1643 scm_misc_error (NULL
,
1644 "bit vectors must have equal length",
1647 bits1
= scm_bitvector_writable_elements (v
);
1648 bits2
= scm_bitvector_elements (kv
);
1651 for (i
= 0; i
< word_len
; i
++)
1652 bits1
[i
] &= ~bits2
[i
];
1654 for (i
= 0; i
< word_len
; i
++)
1655 bits1
[i
] |= bits2
[i
];
1657 scm_bitvector_release_elements (kv
);
1658 scm_bitvector_release_writable_elements (v
);
1660 else if (scm_is_true (scm_u32vector_p (kv
)))
1663 const scm_t_uint32
*indices
;
1665 /* assert that obj is a boolean.
1669 scm_frame_begin (0);
1671 ulen
= scm_c_uniform_vector_length (kv
);
1672 indices
= scm_u32vector_elements (kv
);
1673 scm_frame_uniform_vector_release_elements (kv
);
1675 for (i
= 0; i
< ulen
; i
++)
1676 scm_c_bitvector_set_x (v
, (size_t)indices
[i
], obj
);
1681 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1683 return SCM_UNSPECIFIED
;
1688 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1689 (SCM v
, SCM kv
, SCM obj
),
1690 "Return a count of how many entries in bit vector @var{v} are\n"
1691 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1694 "If @var{kv} is a bit vector, then those entries where it has\n"
1695 "@code{#t} are the ones in @var{v} which are considered.\n"
1696 "@var{kv} and @var{v} must be the same length.\n"
1698 "If @var{kv} is a u32vector, then it contains\n"
1699 "the indexes in @var{v} to consider.\n"
1704 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1705 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
1707 #define FUNC_NAME s_scm_bit_count_star
1709 if (scm_is_bitvector (kv
))
1711 size_t bit_len
= scm_c_bitvector_length (kv
);
1712 size_t word_len
= (bit_len
+ 31) / 32;
1713 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1714 scm_t_uint32 xor_mask
= scm_to_bool (obj
)? 0 : ((scm_t_uint32
)-1);
1715 const scm_t_uint32
*bits1
, *bits2
;
1716 size_t count
= 0, i
;
1718 if (scm_c_bitvector_length (v
) != bit_len
)
1719 scm_misc_error (NULL
,
1720 "bit vectors must have equal length",
1724 return scm_from_size_t (0);
1726 bits1
= scm_bitvector_elements (v
);
1727 bits2
= scm_bitvector_elements (kv
);
1729 for (i
= 0; i
< word_len
-1; i
++)
1730 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
]);
1731 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
] & last_mask
);
1733 scm_bitvector_release_elements (kv
);
1734 scm_bitvector_release_elements (v
);
1736 return scm_from_size_t (count
);
1738 else if (scm_is_true (scm_u32vector_p (kv
)))
1740 size_t count
= 0, ulen
, i
;
1741 const scm_t_uint32
*indices
;
1742 int bit
= scm_to_bool (obj
);
1744 scm_frame_begin (0);
1746 ulen
= scm_c_uniform_vector_length (kv
);
1747 indices
= scm_u32vector_elements (kv
);
1748 scm_frame_uniform_vector_release_elements (kv
);
1750 for (i
= 0; i
< ulen
; i
++)
1751 if ((scm_is_true (scm_c_bitvector_ref (v
, (size_t)indices
[i
])) != 0)
1757 return scm_from_size_t (count
);
1760 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1765 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1767 "Modify the bit vector @var{v} by replacing each element with\n"
1769 #define FUNC_NAME s_scm_bit_invert_x
1771 size_t bit_len
= scm_c_bitvector_length (v
);
1772 size_t word_len
= (bit_len
+ 31) / 32;
1773 scm_t_uint32
*bits
= scm_bitvector_writable_elements (v
);
1776 for (i
= 0; i
< word_len
; i
++)
1779 scm_bitvector_release_writable_elements (v
);
1780 return SCM_UNSPECIFIED
;
1786 scm_istr2bve (SCM str
)
1788 size_t len
= scm_i_string_length (str
);
1789 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
1794 const char *c_str
= scm_i_string_chars (str
);
1795 scm_t_uint32
*data
= scm_bitvector_writable_elements (vec
);
1797 for (k
= 0; k
< (len
+ 31) / 32; k
++)
1803 for (mask
= 1L; j
--; mask
<<= 1)
1818 scm_remember_upto_here_1 (str
);
1819 scm_bitvector_release_writable_elements (vec
);
1826 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
1829 long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1831 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
1833 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
1835 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
1836 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1841 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
1849 res
= scm_cons (scm_i_cvref (SCM_ARRAY_V (ra
), i
, enclosed
),
1857 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
1859 "Return a list consisting of all the elements, in order, of\n"
1861 #define FUNC_NAME s_scm_array_to_list
1863 if (scm_is_generalized_vector (v
))
1864 return scm_generalized_vector_to_list (v
);
1865 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1866 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
1868 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1873 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
1875 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
1876 (SCM ndim
, SCM prot
, SCM lst
),
1877 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
1878 "Return a uniform array of the type indicated by prototype\n"
1879 "@var{prot} with elements the same as those of @var{lst}.\n"
1880 "Elements must be of the appropriate type, no coercions are\n"
1883 "The argument @var{ndim} determines the number of dimensions\n"
1884 "of the array. It is either an exact integer, giving the\n"
1885 "number directly, or a list of exact integers, whose length\n"
1886 "specifies the number of dimensions and each element is the\n"
1887 "lower index bound of its dimension.")
1888 #define FUNC_NAME s_scm_list_to_uniform_array
1896 if (scm_is_integer (ndim
))
1898 size_t k
= scm_to_size_t (ndim
);
1901 shape
= scm_cons (scm_length (row
), shape
);
1903 row
= scm_car (row
);
1910 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
1911 scm_sum (scm_sum (scm_car (ndim
),
1913 scm_from_int (-1))),
1915 ndim
= scm_cdr (ndim
);
1916 if (scm_is_pair (ndim
))
1917 row
= scm_car (row
);
1923 ra
= scm_dimensions_to_uniform_array (scm_reverse_x (shape
, SCM_EOL
), prot
,
1926 if (scm_is_null (shape
))
1928 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
1929 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
1932 if (!SCM_ARRAYP (ra
))
1934 size_t length
= scm_c_generalized_vector_length (ra
);
1935 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
1936 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
1939 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
1942 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
1948 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
1950 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1951 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
1954 return (scm_is_null (lst
));
1955 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1959 if (!scm_is_pair (lst
))
1961 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
1963 lst
= SCM_CDR (lst
);
1965 if (!scm_is_null (lst
))
1972 if (!scm_is_pair (lst
))
1974 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
1976 lst
= SCM_CDR (lst
);
1978 if (!scm_is_null (lst
))
1985 /* Print dimension DIM of ARRAY.
1989 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
1990 SCM port
, scm_print_state
*pstate
)
1992 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
1995 scm_putc ('(', port
);
1997 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
1999 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2000 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
2003 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
2005 if (idx
< dim_spec
->ubnd
)
2006 scm_putc (' ', port
);
2007 base
+= dim_spec
->inc
;
2010 scm_putc (')', port
);
2014 /* Print an array. (Only for strict arrays, not for strings, uniform
2015 vectors, vectors and other stuff that can masquerade as an array.)
2018 /* The array tag is generally of the form
2020 * #<rank><unif><@lower><@lower>...
2022 * <rank> is a positive integer in decimal giving the rank of the
2023 * array. It is omitted when the rank is 1 and the array is
2024 * non-shared and has zero-origin. For shared arrays and for a
2025 * non-zero origin, the rank is always printed even when it is 1 to
2026 * dinstinguish them from ordinary vectors.
2028 * <unif> is the tag for a uniform (or homogenous) numeric vector,
2029 * like u8, s16, etc, as defined by SRFI-4. It is omitted when the
2030 * array is not uniform.
2032 * <@lower> is a 'at' sign followed by a integer in decimal giving the
2033 * lower bound of a dimension. There is one <@lower> for each
2034 * dimension. When all lower bounds are zero, all <@lower> are
2039 * #(1 2 3) is non-uniform array of rank 1 with lower bound 0 in
2040 * dimension 0. (I.e., a regular vector.)
2042 * #@2(1 2 3) is non-uniform array of rank 1 with lower bound 2 in
2045 * #2((1 2 3) (4 5 6)) is a non-uniform array of rank 2; a 3x3
2046 * matrix with index ranges 0..2 and 0..2.
2048 * #u32(0 1 2) is a uniform u8 array of rank 1.
2050 * #2u32@2@3((1 2) (2 3)) is a uniform u8 array of rank 2 with index
2051 * ranges 2..3 and 3..4.
2055 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2057 long ndim
= SCM_ARRAY_NDIM (array
);
2058 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2059 SCM v
= SCM_ARRAY_V (array
);
2060 unsigned long base
= SCM_ARRAY_BASE (array
);
2063 scm_putc ('#', port
);
2064 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2065 scm_intprint (ndim
, 10, port
);
2066 if (scm_is_uniform_vector (v
))
2067 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2068 else if (scm_is_bitvector (v
))
2069 scm_puts ("b", port
);
2070 else if (scm_is_string (v
))
2071 scm_puts ("a", port
);
2072 else if (!scm_is_vector (v
))
2073 scm_puts ("?", port
);
2075 for (i
= 0; i
< ndim
; i
++)
2076 if (dim_specs
[i
].lbnd
!= 0)
2078 for (i
= 0; i
< ndim
; i
++)
2080 scm_putc ('@', port
);
2081 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2086 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2090 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2094 scm_putc ('#', port
);
2095 base
= SCM_ARRAY_BASE (array
);
2096 scm_puts ("<enclosed-array ", port
);
2097 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2098 scm_putc ('>', port
);
2102 /* Read an array. This function can also read vectors and uniform
2103 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2106 C is the first character read after the '#'.
2114 static tag_creator tag_creator_table
[] = {
2115 { "", &scm_i_proc_make_vector
},
2116 { "a", &scm_i_proc_make_string
},
2117 { "b", &scm_i_proc_make_bitvector
},
2118 { "u8", &scm_i_proc_make_u8vector
},
2119 { "s8", &scm_i_proc_make_s8vector
},
2120 { "u16", &scm_i_proc_make_u16vector
},
2121 { "s16", &scm_i_proc_make_s16vector
},
2122 { "u32", &scm_i_proc_make_u32vector
},
2123 { "s32", &scm_i_proc_make_s32vector
},
2124 { "u64", &scm_i_proc_make_u64vector
},
2125 { "s64", &scm_i_proc_make_s64vector
},
2126 { "f32", &scm_i_proc_make_f32vector
},
2127 { "f64", &scm_i_proc_make_f64vector
},
2128 { "c32", &scm_i_proc_make_c32vector
},
2129 { "c64", &scm_i_proc_make_c64vector
},
2134 scm_i_tag_to_creator (const char *tag
, SCM port
)
2138 for (tp
= tag_creator_table
; tp
->tag
; tp
++)
2139 if (!strcmp (tp
->tag
, tag
))
2140 return *(tp
->creator_var
);
2142 #if SCM_ENABLE_DEPRECATED
2144 /* Recognize the old syntax, producing the old prototypes.
2146 SCM proto
= SCM_EOL
;
2147 const char *instead
;
2151 proto
= scm_from_int (1);
2155 proto
= scm_from_int (-1);
2159 proto
= scm_from_double (1.0);
2163 proto
= scm_divide (scm_from_int (1), scm_from_int (3));
2167 proto
= SCM_MAKE_CHAR (0);
2171 proto
= scm_from_locale_symbol ("s");
2175 proto
= scm_from_locale_symbol ("l");
2179 proto
= scm_c_make_rectangular (0.0, 1.0);
2186 if (!scm_is_eq (proto
, SCM_EOL
) && tag
[1] == '\0')
2188 scm_c_issue_deprecation_warning_fmt
2189 ("The tag '%c' is deprecated for uniform vectors. "
2190 "Use '%s' instead.", tag
[0], instead
);
2196 scm_i_input_error (NULL
, port
,
2197 "unrecognized uniform array tag: ~a",
2198 scm_list_1 (scm_from_locale_string (tag
)));
2203 scm_i_read_array (SCM port
, int c
)
2210 SCM lower_bounds
, elements
;
2212 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2213 the array code can not deal with zero-length dimensions yet, and
2214 we want to allow zero-length vectors, of course.
2218 scm_ungetc (c
, port
);
2219 return scm_vector (scm_read (port
));
2222 /* Disambiguate between '#f' and uniform floating point vectors.
2226 c
= scm_getc (port
);
2227 if (c
!= '3' && c
!= '6')
2230 scm_ungetc (c
, port
);
2237 goto continue_reading_tag
;
2240 /* Read rank. We disallow arrays of rank zero since they do not
2241 seem to work reliably yet. */
2244 while ('0' <= c
&& c
<= '9')
2246 rank
= 10*rank
+ c
-'0';
2248 c
= scm_getc (port
);
2253 scm_i_input_error (NULL
, port
,
2254 "array rank must be positive", SCM_EOL
);
2258 continue_reading_tag
:
2259 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2262 c
= scm_getc (port
);
2264 tag
[tag_len
] = '\0';
2266 /* Read lower bounds. */
2267 lower_bounds
= SCM_EOL
;
2270 /* Yeah, right, we should use some ready-made integer parsing
2277 c
= scm_getc (port
);
2281 c
= scm_getc (port
);
2283 while ('0' <= c
&& c
<= '9')
2285 lbnd
= 10*lbnd
+ c
-'0';
2286 c
= scm_getc (port
);
2288 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2291 /* Read nested lists of elements.
2294 scm_i_input_error (NULL
, port
,
2295 "missing '(' in vector or array literal",
2297 scm_ungetc (c
, port
);
2298 elements
= scm_read (port
);
2300 if (scm_is_null (lower_bounds
))
2301 lower_bounds
= scm_from_size_t (rank
);
2302 else if (scm_ilength (lower_bounds
) != rank
)
2303 scm_i_input_error (NULL
, port
,
2304 "the number of lower bounds must match the array rank",
2307 /* Construct array. */
2308 return scm_list_to_uniform_array (lower_bounds
,
2309 scm_i_tag_to_creator (tag
, port
),
2314 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2316 scm_iprin1 (exp
, port
, pstate
);
2320 SCM_DEFINE (scm_array_creator
, "array-creator", 1, 0, 0,
2322 "Return a procedure that would produce an array of the same type\n"
2323 "as @var{array} if used as the @var{creator} with\n"
2324 "@code{make-array*}.")
2325 #define FUNC_NAME s_scm_array_creator
2327 if (SCM_ARRAYP (ra
))
2328 return scm_i_generalized_vector_creator (SCM_ARRAY_V (ra
));
2329 else if (scm_is_generalized_vector (ra
))
2330 return scm_i_generalized_vector_creator (ra
);
2331 else if (SCM_ENCLOSED_ARRAYP (ra
))
2332 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2334 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2338 #if SCM_ENABLE_DEPRECATED
2340 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2342 "Return an object that would produce an array of the same type\n"
2343 "as @var{array}, if used as the @var{prototype} for\n"
2344 "@code{make-uniform-array}.")
2345 #define FUNC_NAME s_scm_array_prototype
2347 if (SCM_ARRAYP (ra
))
2348 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2349 else if (scm_is_generalized_vector (ra
))
2350 return scm_i_get_old_prototype (ra
);
2351 else if (SCM_ENCLOSED_ARRAYP (ra
))
2352 return SCM_UNSPECIFIED
;
2354 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2361 array_mark (SCM ptr
)
2363 return SCM_ARRAY_V (ptr
);
2368 array_free (SCM ptr
)
2370 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2371 (sizeof (scm_t_array
)
2372 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2380 scm_tc16_array
= scm_make_smob_type ("array", 0);
2381 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2382 scm_set_smob_free (scm_tc16_array
, array_free
);
2383 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2384 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2386 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2387 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2388 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2389 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2390 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2392 scm_add_feature ("array");
2394 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2395 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2396 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2397 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2399 #include "libguile/unif.x"
2401 scm_i_proc_make_vector
= scm_variable_ref (scm_c_lookup ("make-vector"));
2402 scm_i_proc_make_string
= scm_variable_ref (scm_c_lookup ("make-string"));
2403 scm_i_proc_make_bitvector
=
2404 scm_variable_ref (scm_c_lookup ("make-bitvector"));