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
));
1321 scm_bitvector_elements (SCM vec
)
1323 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1324 return BITVECTOR_BITS (vec
);
1328 scm_bitvector_release (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 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 (SCM vec
)
1344 scm_frame_unwind_handler_with_scm (scm_bitvector_release
, vec
,
1345 SCM_F_WIND_EXPLICITLY
);
1349 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1351 if (idx
< scm_c_bitvector_length (vec
))
1353 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1354 SCM res
= (bits
[idx
/32] & (1L << (idx
%32)))? SCM_BOOL_T
: SCM_BOOL_F
;
1355 scm_bitvector_release (vec
);
1359 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1362 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1364 "Return the element at index @var{idx} of the bitvector\n"
1366 #define FUNC_NAME s_scm_bitvector_ref
1368 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1373 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1375 if (idx
< scm_c_bitvector_length (vec
))
1377 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1378 scm_t_uint32 mask
= 1L << (idx
%32);
1379 if (scm_is_true (val
))
1380 bits
[idx
/32] |= mask
;
1382 bits
[idx
/32] &= ~mask
;
1383 scm_bitvector_release (vec
);
1386 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1389 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1390 (SCM vec
, SCM idx
, SCM val
),
1391 "Set the element at index @var{idx} of the bitvector\n"
1392 "@var{vec} when @var{val} is true, else clear it.")
1393 #define FUNC_NAME s_scm_bitvector_set_x
1395 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1396 return SCM_UNSPECIFIED
;
1400 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1402 "Set all elements of the bitvector\n"
1403 "@var{vec} when @var{val} is true, else clear them.")
1404 #define FUNC_NAME s_scm_bitvector_fill_x
1406 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1407 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1408 size_t word_len
= (bit_len
+ 31) / 32;
1409 memset (bits
, scm_is_true (val
)? -1:0, sizeof (scm_t_uint32
) * word_len
);
1410 scm_bitvector_release (vec
);
1411 return SCM_UNSPECIFIED
;
1415 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1417 "Return a new bitvector initialized with the elements\n"
1419 #define FUNC_NAME s_scm_list_to_bitvector
1421 size_t bit_len
= scm_to_size_t (scm_length (list
));
1422 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1423 size_t word_len
= (bit_len
+31)/32;
1424 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1427 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1429 scm_t_uint32 mask
= 1;
1431 for (j
= 0; j
< 32 && j
< bit_len
;
1432 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1433 if (scm_is_true (SCM_CAR (list
)))
1437 scm_bitvector_release (vec
);
1442 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1444 "Return a new list initialized with the elements\n"
1445 "of the bitvector @var{vec}.")
1446 #define FUNC_NAME s_scm_bitvector_to_list
1448 size_t bit_len
= scm_c_bitvector_length (vec
);
1450 size_t word_len
= (bit_len
+31)/32;
1451 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1454 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1456 scm_t_uint32 mask
= 1;
1457 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1458 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1461 scm_bitvector_release (vec
);
1462 return scm_reverse_x (res
, SCM_EOL
);
1466 /* From mmix-arith.w by Knuth.
1468 Here's a fun way to count the number of bits in a tetrabyte.
1470 [This classical trick is called the ``Gillies--Miller method for
1471 sideways addition'' in {\sl The Preparation of Programs for an
1472 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1473 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1474 the tricks used here were suggested by Balbir Singh, Peter
1475 Rossmanith, and Stefan Schwoon.]
1479 count_ones (scm_t_uint32 x
)
1481 x
=x
-((x
>>1)&0x55555555);
1482 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1483 x
=(x
+(x
>>4))&0x0f0f0f0f;
1485 return (x
+(x
>>16)) & 0xff;
1488 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1489 (SCM b
, SCM bitvector
),
1490 "Return the number of occurrences of the boolean @var{b} in\n"
1492 #define FUNC_NAME s_scm_bit_count
1494 size_t bit_len
= scm_c_bitvector_length (bitvector
);
1495 size_t word_len
= (bit_len
+ 31) / 32;
1496 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1497 scm_t_uint32
*bits
= scm_bitvector_elements (bitvector
);
1499 int bit
= scm_to_bool (b
);
1500 size_t count
= 0, i
;
1505 for (i
= 0; i
< word_len
-1; i
++)
1506 count
+= count_ones (bits
[i
]);
1507 count
+= count_ones (bits
[i
] & last_mask
);
1509 scm_bitvector_release (bitvector
);
1510 return scm_from_size_t (bit
? count
: bit_len
-count
);
1514 /* returns 32 for x == 0.
1517 find_first_one (scm_t_uint32 x
)
1520 /* do a binary search in x. */
1521 if ((x
& 0xFFFF) == 0)
1522 x
>>= 16, pos
+= 16;
1523 if ((x
& 0xFF) == 0)
1534 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1535 (SCM item
, SCM v
, SCM k
),
1536 "Return the index of the first occurrance of @var{item} in bit\n"
1537 "vector @var{v}, starting from @var{k}. If there is no\n"
1538 "@var{item} entry between @var{k} and the end of\n"
1539 "@var{bitvector}, then return @code{#f}. For example,\n"
1542 "(bit-position #t #*000101 0) @result{} 3\n"
1543 "(bit-position #f #*0001111 3) @result{} #f\n"
1545 #define FUNC_NAME s_scm_bit_position
1547 size_t bit_len
= scm_c_bitvector_length (v
);
1548 size_t word_len
= (bit_len
+ 31) / 32;
1549 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1550 scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1551 size_t first_bit
= scm_to_unsigned_integer (k
, 0, bit_len
);
1552 size_t first_word
= first_bit
/ 32;
1553 scm_t_uint32 first_mask
= ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1556 int bit
= scm_to_bool (item
);
1558 SCM res
= SCM_BOOL_F
;
1563 for (i
= first_word
; i
< word_len
; i
++)
1565 w
= (bit
? bits
[i
] : ~bits
[i
]);
1566 if (i
== first_word
)
1568 if (i
== word_len
-1)
1572 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1577 scm_bitvector_release (v
);
1582 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1583 (SCM v
, SCM kv
, SCM obj
),
1584 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1585 "selecting the entries to change. The return value is\n"
1588 "If @var{kv} is a bit vector, then those entries where it has\n"
1589 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1590 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1591 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1592 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1595 "(define bv #*01000010)\n"
1596 "(bit-set*! bv #*10010001 #t)\n"
1598 "@result{} #*11010011\n"
1601 "If @var{kv} is a u32vector, then its elements are\n"
1602 "indices into @var{v} which are set to @var{obj}.\n"
1605 "(define bv #*01000010)\n"
1606 "(bit-set*! bv #u32(5 2 7) #t)\n"
1608 "@result{} #*01100111\n"
1610 #define FUNC_NAME s_scm_bit_set_star_x
1612 if (scm_is_bitvector (kv
))
1614 size_t bit_len
= scm_c_bitvector_length (kv
);
1615 size_t word_len
= (bit_len
+ 31) / 32;
1616 scm_t_uint32
*bits1
, *bits2
;
1618 int bit
= scm_to_bool (obj
);
1620 if (scm_c_bitvector_length (v
) != bit_len
)
1621 scm_misc_error (NULL
,
1622 "bit vectors must have equal length",
1625 bits1
= scm_bitvector_elements (v
);
1626 bits2
= scm_bitvector_elements (kv
);
1629 for (i
= 0; i
< word_len
; i
++)
1630 bits1
[i
] &= ~bits2
[i
];
1632 for (i
= 0; i
< word_len
; i
++)
1633 bits1
[i
] |= bits2
[i
];
1635 scm_bitvector_release (kv
);
1636 scm_bitvector_release (v
);
1638 else if (scm_is_true (scm_u32vector_p (kv
)))
1641 const scm_t_uint32
*indices
;
1643 /* assert that obj is a boolean.
1647 scm_frame_begin (0);
1649 ulen
= scm_c_uniform_vector_length (kv
);
1650 indices
= scm_u32vector_elements (kv
);
1651 scm_frame_uniform_vector_release_elements (kv
);
1653 for (i
= 0; i
< ulen
; i
++)
1654 scm_c_bitvector_set_x (v
, (size_t)indices
[i
], obj
);
1659 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1661 return SCM_UNSPECIFIED
;
1666 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1667 (SCM v
, SCM kv
, SCM obj
),
1668 "Return a count of how many entries in bit vector @var{v} are\n"
1669 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1672 "If @var{kv} is a bit vector, then those entries where it has\n"
1673 "@code{#t} are the ones in @var{v} which are considered.\n"
1674 "@var{kv} and @var{v} must be the same length.\n"
1676 "If @var{kv} is a u32vector, then it contains\n"
1677 "the indexes in @var{v} to consider.\n"
1682 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1683 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
1685 #define FUNC_NAME s_scm_bit_count_star
1687 if (scm_is_bitvector (kv
))
1689 size_t bit_len
= scm_c_bitvector_length (kv
);
1690 size_t word_len
= (bit_len
+ 31) / 32;
1691 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1692 scm_t_uint32 xor_mask
= scm_to_bool (obj
)? 0 : ((scm_t_uint32
)-1);
1693 scm_t_uint32
*bits1
, *bits2
;
1694 size_t count
= 0, i
;
1696 if (scm_c_bitvector_length (v
) != bit_len
)
1697 scm_misc_error (NULL
,
1698 "bit vectors must have equal length",
1702 return scm_from_size_t (0);
1704 bits1
= scm_bitvector_elements (v
);
1705 bits2
= scm_bitvector_elements (kv
);
1707 for (i
= 0; i
< word_len
-1; i
++)
1708 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
]);
1709 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
] & last_mask
);
1711 scm_bitvector_release (kv
);
1712 scm_bitvector_release (v
);
1714 return scm_from_size_t (count
);
1716 else if (scm_is_true (scm_u32vector_p (kv
)))
1718 size_t count
= 0, ulen
, i
;
1719 const scm_t_uint32
*indices
;
1720 int bit
= scm_to_bool (obj
);
1722 scm_frame_begin (0);
1724 ulen
= scm_c_uniform_vector_length (kv
);
1725 indices
= scm_u32vector_elements (kv
);
1726 scm_frame_uniform_vector_release_elements (kv
);
1728 for (i
= 0; i
< ulen
; i
++)
1729 if ((scm_is_true (scm_c_bitvector_ref (v
, (size_t)indices
[i
])) != 0)
1735 return scm_from_size_t (count
);
1738 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1743 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1745 "Modify the bit vector @var{v} by replacing each element with\n"
1747 #define FUNC_NAME s_scm_bit_invert_x
1749 size_t bit_len
= scm_c_bitvector_length (v
);
1750 size_t word_len
= (bit_len
+ 31) / 32;
1751 scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1754 for (i
= 0; i
< word_len
; i
++)
1757 scm_bitvector_release (v
);
1758 return SCM_UNSPECIFIED
;
1764 scm_istr2bve (SCM str
)
1766 size_t len
= scm_i_string_length (str
);
1767 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
1772 const char *c_str
= scm_i_string_chars (str
);
1773 scm_t_uint32
*data
= scm_bitvector_elements (vec
);
1775 for (k
= 0; k
< (len
+ 31) / 32; k
++)
1781 for (mask
= 1L; j
--; mask
<<= 1)
1796 scm_remember_upto_here_1 (str
);
1797 scm_bitvector_release (vec
);
1804 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
1807 long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1809 int enclosed
= SCM_ENCLOSED_ARRAYP (ra
);
1811 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
1813 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
1814 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1819 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
1827 res
= scm_cons (scm_i_cvref (SCM_ARRAY_V (ra
), i
, enclosed
),
1835 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
1837 "Return a list consisting of all the elements, in order, of\n"
1839 #define FUNC_NAME s_scm_array_to_list
1841 if (scm_is_generalized_vector (v
))
1842 return scm_generalized_vector_to_list (v
);
1843 else if (SCM_ARRAYP (v
) || SCM_ENCLOSED_ARRAYP (v
))
1844 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
1846 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1851 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
1853 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
1854 (SCM ndim
, SCM prot
, SCM lst
),
1855 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
1856 "Return a uniform array of the type indicated by prototype\n"
1857 "@var{prot} with elements the same as those of @var{lst}.\n"
1858 "Elements must be of the appropriate type, no coercions are\n"
1861 "The argument @var{ndim} determines the number of dimensions\n"
1862 "of the array. It is either an exact integer, giving the\n"
1863 "number directly, or a list of exact integers, whose length\n"
1864 "specifies the number of dimensions and each element is the\n"
1865 "lower index bound of its dimension.")
1866 #define FUNC_NAME s_scm_list_to_uniform_array
1874 if (scm_is_integer (ndim
))
1876 size_t k
= scm_to_size_t (ndim
);
1879 shape
= scm_cons (scm_length (row
), shape
);
1881 row
= scm_car (row
);
1888 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
1889 scm_sum (scm_sum (scm_car (ndim
),
1891 scm_from_int (-1))),
1893 ndim
= scm_cdr (ndim
);
1894 if (scm_is_pair (ndim
))
1895 row
= scm_car (row
);
1901 ra
= scm_dimensions_to_uniform_array (scm_reverse_x (shape
, SCM_EOL
), prot
,
1904 if (scm_is_null (shape
))
1906 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
1907 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
1910 if (!SCM_ARRAYP (ra
))
1912 size_t length
= scm_c_generalized_vector_length (ra
);
1913 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
1914 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
1917 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
1920 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
1926 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
1928 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1929 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
1932 return (scm_is_null (lst
));
1933 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1937 if (!scm_is_pair (lst
))
1939 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
1941 lst
= SCM_CDR (lst
);
1943 if (!scm_is_null (lst
))
1950 if (!scm_is_pair (lst
))
1952 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
1954 lst
= SCM_CDR (lst
);
1956 if (!scm_is_null (lst
))
1963 /* Print dimension DIM of ARRAY.
1967 scm_i_print_array_dimension (SCM array
, int dim
, int base
, int enclosed
,
1968 SCM port
, scm_print_state
*pstate
)
1970 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
1973 scm_putc ('(', port
);
1975 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
1977 if (dim
< SCM_ARRAY_NDIM(array
)-1)
1978 scm_i_print_array_dimension (array
, dim
+1, base
, enclosed
,
1981 scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array
), base
, enclosed
),
1983 if (idx
< dim_spec
->ubnd
)
1984 scm_putc (' ', port
);
1985 base
+= dim_spec
->inc
;
1988 scm_putc (')', port
);
1992 /* Print an array. (Only for strict arrays, not for strings, uniform
1993 vectors, vectors and other stuff that can masquerade as an array.)
1996 /* The array tag is generally of the form
1998 * #<rank><unif><@lower><@lower>...
2000 * <rank> is a positive integer in decimal giving the rank of the
2001 * array. It is omitted when the rank is 1 and the array is
2002 * non-shared and has zero-origin. For shared arrays and for a
2003 * non-zero origin, the rank is always printed even when it is 1 to
2004 * dinstinguish them from ordinary vectors.
2006 * <unif> is the tag for a uniform (or homogenous) numeric vector,
2007 * like u8, s16, etc, as defined by SRFI-4. It is omitted when the
2008 * array is not uniform.
2010 * <@lower> is a 'at' sign followed by a integer in decimal giving the
2011 * lower bound of a dimension. There is one <@lower> for each
2012 * dimension. When all lower bounds are zero, all <@lower> are
2017 * #(1 2 3) is non-uniform array of rank 1 with lower bound 0 in
2018 * dimension 0. (I.e., a regular vector.)
2020 * #@2(1 2 3) is non-uniform array of rank 1 with lower bound 2 in
2023 * #2((1 2 3) (4 5 6)) is a non-uniform array of rank 2; a 3x3
2024 * matrix with index ranges 0..2 and 0..2.
2026 * #u32(0 1 2) is a uniform u8 array of rank 1.
2028 * #2u32@2@3((1 2) (2 3)) is a uniform u8 array of rank 2 with index
2029 * ranges 2..3 and 3..4.
2033 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2035 long ndim
= SCM_ARRAY_NDIM (array
);
2036 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2037 SCM v
= SCM_ARRAY_V (array
);
2038 unsigned long base
= SCM_ARRAY_BASE (array
);
2041 scm_putc ('#', port
);
2042 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2043 scm_intprint (ndim
, 10, port
);
2044 if (scm_is_uniform_vector (v
))
2045 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2046 else if (scm_is_bitvector (v
))
2047 scm_puts ("b", port
);
2048 else if (scm_is_string (v
))
2049 scm_puts ("a", port
);
2050 else if (!scm_is_vector (v
))
2051 scm_puts ("?", port
);
2053 for (i
= 0; i
< ndim
; i
++)
2054 if (dim_specs
[i
].lbnd
!= 0)
2056 for (i
= 0; i
< ndim
; i
++)
2058 scm_putc ('@', port
);
2059 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2064 return scm_i_print_array_dimension (array
, 0, base
, 0, port
, pstate
);
2068 scm_i_print_enclosed_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2072 scm_putc ('#', port
);
2073 base
= SCM_ARRAY_BASE (array
);
2074 scm_puts ("<enclosed-array ", port
);
2075 scm_i_print_array_dimension (array
, 0, base
, 1, port
, pstate
);
2076 scm_putc ('>', port
);
2080 /* Read an array. This function can also read vectors and uniform
2081 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2084 C is the first character read after the '#'.
2092 static tag_creator tag_creator_table
[] = {
2093 { "", &scm_i_proc_make_vector
},
2094 { "a", &scm_i_proc_make_string
},
2095 { "b", &scm_i_proc_make_bitvector
},
2096 { "u8", &scm_i_proc_make_u8vector
},
2097 { "s8", &scm_i_proc_make_s8vector
},
2098 { "u16", &scm_i_proc_make_u16vector
},
2099 { "s16", &scm_i_proc_make_s16vector
},
2100 { "u32", &scm_i_proc_make_u32vector
},
2101 { "s32", &scm_i_proc_make_s32vector
},
2102 { "u64", &scm_i_proc_make_u64vector
},
2103 { "s64", &scm_i_proc_make_s64vector
},
2104 { "f32", &scm_i_proc_make_f32vector
},
2105 { "f64", &scm_i_proc_make_f64vector
},
2106 { "c32", &scm_i_proc_make_c32vector
},
2107 { "c64", &scm_i_proc_make_c64vector
},
2112 scm_i_tag_to_creator (const char *tag
, SCM port
)
2116 for (tp
= tag_creator_table
; tp
->tag
; tp
++)
2117 if (!strcmp (tp
->tag
, tag
))
2118 return *(tp
->creator_var
);
2120 #if SCM_ENABLE_DEPRECATED
2122 /* Recognize the old syntax, producing the old prototypes.
2124 SCM proto
= SCM_EOL
;
2125 const char *instead
;
2129 proto
= scm_from_int (1);
2133 proto
= scm_from_int (-1);
2137 proto
= scm_from_double (1.0);
2141 proto
= scm_divide (scm_from_int (1), scm_from_int (3));
2145 proto
= SCM_MAKE_CHAR (0);
2149 proto
= scm_from_locale_symbol ("s");
2153 proto
= scm_from_locale_symbol ("l");
2157 proto
= scm_c_make_rectangular (0.0, 1.0);
2164 if (!scm_is_eq (proto
, SCM_EOL
) && tag
[1] == '\0')
2166 scm_c_issue_deprecation_warning_fmt
2167 ("The tag '%c' is deprecated for uniform vectors. "
2168 "Use '%s' instead.", tag
[0], instead
);
2174 scm_i_input_error (NULL
, port
,
2175 "unrecognized uniform array tag: ~a",
2176 scm_list_1 (scm_from_locale_string (tag
)));
2181 scm_i_read_array (SCM port
, int c
)
2188 SCM lower_bounds
, elements
;
2190 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2191 the array code can not deal with zero-length dimensions yet, and
2192 we want to allow zero-length vectors, of course.
2196 scm_ungetc (c
, port
);
2197 return scm_vector (scm_read (port
));
2200 /* Disambiguate between '#f' and uniform floating point vectors.
2204 c
= scm_getc (port
);
2205 if (c
!= '3' && c
!= '6')
2208 scm_ungetc (c
, port
);
2215 goto continue_reading_tag
;
2218 /* Read rank. We disallow arrays of rank zero since they do not
2219 seem to work reliably yet. */
2222 while ('0' <= c
&& c
<= '9')
2224 rank
= 10*rank
+ c
-'0';
2226 c
= scm_getc (port
);
2231 scm_i_input_error (NULL
, port
,
2232 "array rank must be positive", SCM_EOL
);
2236 continue_reading_tag
:
2237 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2240 c
= scm_getc (port
);
2242 tag
[tag_len
] = '\0';
2244 /* Read lower bounds. */
2245 lower_bounds
= SCM_EOL
;
2248 /* Yeah, right, we should use some ready-made integer parsing
2255 c
= scm_getc (port
);
2259 c
= scm_getc (port
);
2261 while ('0' <= c
&& c
<= '9')
2263 lbnd
= 10*lbnd
+ c
-'0';
2264 c
= scm_getc (port
);
2266 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2269 /* Read nested lists of elements.
2272 scm_i_input_error (NULL
, port
,
2273 "missing '(' in vector or array literal",
2275 scm_ungetc (c
, port
);
2276 elements
= scm_read (port
);
2278 if (scm_is_null (lower_bounds
))
2279 lower_bounds
= scm_from_size_t (rank
);
2280 else if (scm_ilength (lower_bounds
) != rank
)
2281 scm_i_input_error (NULL
, port
,
2282 "the number of lower bounds must match the array rank",
2285 /* Construct array. */
2286 return scm_list_to_uniform_array (lower_bounds
,
2287 scm_i_tag_to_creator (tag
, port
),
2292 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2294 scm_iprin1 (exp
, port
, pstate
);
2298 SCM_DEFINE (scm_array_creator
, "array-creator", 1, 0, 0,
2300 "Return a procedure that would produce an array of the same type\n"
2301 "as @var{array} if used as the @var{creator} with\n"
2302 "@code{make-array*}.")
2303 #define FUNC_NAME s_scm_array_creator
2305 if (SCM_ARRAYP (ra
))
2306 return scm_i_generalized_vector_creator (SCM_ARRAY_V (ra
));
2307 else if (scm_is_generalized_vector (ra
))
2308 return scm_i_generalized_vector_creator (ra
);
2309 else if (SCM_ENCLOSED_ARRAYP (ra
))
2310 scm_wrong_type_arg_msg (NULL
, 0, ra
, "non-enclosed array");
2312 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2316 #if SCM_ENABLE_DEPRECATED
2318 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2320 "Return an object that would produce an array of the same type\n"
2321 "as @var{array}, if used as the @var{prototype} for\n"
2322 "@code{make-uniform-array}.")
2323 #define FUNC_NAME s_scm_array_prototype
2325 if (SCM_ARRAYP (ra
))
2326 return scm_i_get_old_prototype (SCM_ARRAY_V (ra
));
2327 else if (scm_is_generalized_vector (ra
))
2328 return scm_i_get_old_prototype (ra
);
2329 else if (SCM_ENCLOSED_ARRAYP (ra
))
2330 return SCM_UNSPECIFIED
;
2332 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2339 array_mark (SCM ptr
)
2341 return SCM_ARRAY_V (ptr
);
2346 array_free (SCM ptr
)
2348 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2349 (sizeof (scm_t_array
)
2350 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2358 scm_tc16_array
= scm_make_smob_type ("array", 0);
2359 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2360 scm_set_smob_free (scm_tc16_array
, array_free
);
2361 scm_set_smob_print (scm_tc16_array
, scm_i_print_array
);
2362 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2364 scm_tc16_enclosed_array
= scm_make_smob_type ("enclosed-array", 0);
2365 scm_set_smob_mark (scm_tc16_enclosed_array
, array_mark
);
2366 scm_set_smob_free (scm_tc16_enclosed_array
, array_free
);
2367 scm_set_smob_print (scm_tc16_enclosed_array
, scm_i_print_enclosed_array
);
2368 scm_set_smob_equalp (scm_tc16_enclosed_array
, scm_array_equal_p
);
2370 scm_add_feature ("array");
2372 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2373 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2374 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2375 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2377 #include "libguile/unif.x"
2379 scm_i_proc_make_vector
= scm_variable_ref (scm_c_lookup ("make-vector"));
2380 scm_i_proc_make_string
= scm_variable_ref (scm_c_lookup ("make-string"));
2381 scm_i_proc_make_bitvector
=
2382 scm_variable_ref (scm_c_lookup ("make-bitvector"));