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 static SCM exactly_one_third
;
86 /* Silly function used not to modify the semantics of the silly
87 * prototype system in order to be backward compatible.
96 double x
= SCM_REAL_VALUE (obj
);
98 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
103 SCM scm_i_proc_make_vector
;
104 SCM scm_i_proc_make_string
;
105 SCM scm_i_proc_make_bitvector
;
107 #if SCM_ENABLE_DEPRECATED
109 SCM_SYMBOL (scm_sym_s
, "s");
110 SCM_SYMBOL (scm_sym_l
, "l");
113 scm_i_convert_old_prototype (SCM proto
)
117 /* All new 'prototypes' are creator procedures.
119 if (scm_is_true (scm_procedure_p (proto
)))
122 if (scm_is_eq (proto
, SCM_BOOL_T
))
123 new_proto
= scm_i_proc_make_bitvector
;
124 else if (scm_is_eq (proto
, SCM_MAKE_CHAR ('a')))
125 new_proto
= scm_i_proc_make_string
;
126 else if (scm_is_eq (proto
, SCM_MAKE_CHAR (0)))
127 new_proto
= scm_i_proc_make_s8vector
;
128 else if (scm_is_eq (proto
, scm_sym_s
))
129 new_proto
= scm_i_proc_make_s16vector
;
130 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (1))))
131 new_proto
= scm_i_proc_make_u32vector
;
132 else if (scm_is_true (scm_eqv_p (proto
, scm_from_int (-1))))
133 new_proto
= scm_i_proc_make_s32vector
;
134 else if (scm_is_eq (proto
, scm_sym_l
))
135 new_proto
= scm_i_proc_make_s64vector
;
136 else if (scm_is_true (scm_eqv_p (proto
, scm_from_double (1.0))))
137 new_proto
= scm_i_proc_make_f32vector
;
138 else if (scm_is_true (scm_eqv_p (proto
, scm_divide (scm_from_int (1),
140 new_proto
= scm_i_proc_make_f64vector
;
141 else if (scm_is_true (scm_eqv_p (proto
, scm_c_make_rectangular (0, 1))))
142 new_proto
= scm_i_proc_make_c64vector
;
143 else if (scm_is_null (proto
))
144 new_proto
= scm_i_proc_make_vector
;
148 scm_c_issue_deprecation_warning
149 ("Using prototypes with arrays is deprecated. "
150 "Use creator functions instead.");
156 scm_i_get_old_prototype (SCM uvec
)
158 if (scm_is_bitvector (uvec
))
160 else if (scm_is_string (uvec
))
161 return SCM_MAKE_CHAR ('a');
162 else if (scm_is_true (scm_s8vector_p (uvec
)))
163 return SCM_MAKE_CHAR ('\0');
164 else if (scm_is_true (scm_s16vector_p (uvec
)))
166 else if (scm_is_true (scm_u32vector_p (uvec
)))
167 return scm_from_int (1);
168 else if (scm_is_true (scm_s32vector_p (uvec
)))
169 return scm_from_int (-1);
170 else if (scm_is_true (scm_s64vector_p (uvec
)))
172 else if (scm_is_true (scm_f32vector_p (uvec
)))
173 return scm_from_double (1.0);
174 else if (scm_is_true (scm_f64vector_p (uvec
)))
175 return scm_divide (scm_from_int (1), scm_from_int (3));
176 else if (scm_is_true (scm_c64vector_p (uvec
)))
177 return scm_c_make_rectangular (0, 1);
178 else if (scm_is_vector (uvec
))
181 return SCM_UNSPECIFIED
;
187 scm_make_uve (long k
, SCM prot
)
188 #define FUNC_NAME "scm_make_uve"
191 #if SCM_ENABLE_DEPRECATED
192 prot
= scm_i_convert_old_prototype (prot
);
194 res
= scm_call_1 (prot
, scm_from_long (k
));
195 if (!scm_is_generalized_vector (res
))
196 scm_wrong_type_arg_msg (NULL
, 0, res
, "generalized vector");
201 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
203 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
204 "not. The @var{prototype} argument is used with uniform arrays\n"
205 "and is described elsewhere.")
206 #define FUNC_NAME s_scm_array_p
208 int nprot
= SCM_UNBNDP (prot
);
211 /* Get storage vector.
213 while (SCM_ARRAYP (v
))
222 /* It must be a generalized vector (which includes vectors, strings, etc).
224 if (!scm_is_generalized_vector (v
))
230 #if SCM_ENABLE_DEPRECATED
231 prot
= scm_i_convert_old_prototype (prot
);
233 return scm_eq_p (prot
, scm_i_generalized_vector_creator (v
));
238 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
240 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
241 "not an array, @code{0} is returned.")
242 #define FUNC_NAME s_scm_array_rank
244 if (scm_is_generalized_vector (ra
))
245 return scm_from_int (1);
248 return scm_from_size_t (SCM_ARRAY_NDIM (ra
));
250 return scm_from_int (0);
255 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
257 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
258 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
260 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
262 #define FUNC_NAME s_scm_array_dimensions
264 if (scm_is_generalized_vector (ra
))
265 return scm_cons (scm_generalized_vector_length (ra
), SCM_EOL
);
273 k
= SCM_ARRAY_NDIM (ra
);
274 s
= SCM_ARRAY_DIMS (ra
);
276 res
= scm_cons (s
[k
].lbnd
277 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
278 scm_from_long (s
[k
].ubnd
),
280 : scm_from_long (1 + s
[k
].ubnd
),
285 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
290 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
292 "Return the root vector of a shared array.")
293 #define FUNC_NAME s_scm_shared_array_root
295 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
296 return SCM_ARRAY_V (ra
);
301 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
303 "Return the root vector index of the first element in the array.")
304 #define FUNC_NAME s_scm_shared_array_offset
306 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
307 return scm_from_int (SCM_ARRAY_BASE (ra
));
312 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
314 "For each dimension, return the distance between elements in the root vector.")
315 #define FUNC_NAME s_scm_shared_array_increments
320 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
321 k
= SCM_ARRAY_NDIM (ra
);
322 s
= SCM_ARRAY_DIMS (ra
);
324 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
330 static char s_bad_ind
[] = "Bad scm_array index";
334 scm_aind (SCM ra
, SCM args
, const char *what
)
335 #define FUNC_NAME what
339 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
340 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
341 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
342 if (scm_is_integer (args
))
345 scm_error_num_args_subr (what
);
346 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
348 while (k
&& scm_is_pair (args
))
350 ind
= SCM_CAR (args
);
351 args
= SCM_CDR (args
);
352 if (!scm_is_integer (ind
))
353 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
354 j
= scm_to_long (ind
);
355 if (j
< s
->lbnd
|| j
> s
->ubnd
)
356 scm_out_of_range (what
, ind
);
357 pos
+= (j
- s
->lbnd
) * (s
->inc
);
361 if (k
!= 0 || !scm_is_null (args
))
362 scm_error_num_args_subr (what
);
370 scm_make_ra (int ndim
)
374 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_tc16_array
,
375 scm_gc_malloc ((sizeof (scm_t_array
) +
376 ndim
* sizeof (scm_t_array_dim
)),
378 SCM_ARRAY_V (ra
) = scm_nullvect
;
383 static char s_bad_spec
[] = "Bad scm_array dimension";
384 /* Increments will still need to be set. */
388 scm_shap2ra (SCM args
, const char *what
)
392 int ndim
= scm_ilength (args
);
394 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
396 ra
= scm_make_ra (ndim
);
397 SCM_ARRAY_BASE (ra
) = 0;
398 s
= SCM_ARRAY_DIMS (ra
);
399 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
401 spec
= SCM_CAR (args
);
402 if (scm_is_integer (spec
))
404 if (scm_to_long (spec
) < 0)
405 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
407 s
->ubnd
= scm_to_long (spec
) - 1;
412 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
413 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
414 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
416 if (!scm_is_pair (sp
)
417 || !scm_is_integer (SCM_CAR (sp
))
418 || !scm_is_null (SCM_CDR (sp
)))
419 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
420 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
427 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
428 (SCM dims
, SCM prot
, SCM fill
),
429 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
430 "Create and return a uniform array or vector of type\n"
431 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
432 "length @var{length}. If @var{fill} is supplied, it's used to\n"
433 "fill the array, otherwise @var{prototype} is used.")
434 #define FUNC_NAME s_scm_dimensions_to_uniform_array
437 unsigned long rlen
= 1;
441 if (scm_is_integer (dims
))
443 SCM answer
= scm_make_uve (scm_to_long (dims
), prot
);
444 if (!SCM_UNBNDP (fill
))
445 scm_array_fill_x (answer
, fill
);
446 else if (scm_is_symbol (prot
) || scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
447 scm_array_fill_x (answer
, scm_from_int (0));
448 else if (scm_is_false (scm_procedure_p (prot
)))
449 scm_array_fill_x (answer
, prot
);
453 SCM_ASSERT (scm_is_null (dims
) || scm_is_pair (dims
),
454 dims
, SCM_ARG1
, FUNC_NAME
);
455 ra
= scm_shap2ra (dims
, FUNC_NAME
);
456 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
457 s
= SCM_ARRAY_DIMS (ra
);
458 k
= SCM_ARRAY_NDIM (ra
);
463 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
464 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
467 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
469 if (!SCM_UNBNDP (fill
))
470 scm_array_fill_x (ra
, fill
);
471 else if (scm_is_symbol (prot
) || scm_is_eq (prot
, SCM_MAKE_CHAR (0)))
472 scm_array_fill_x (ra
, scm_from_int (0));
473 else if (scm_is_false (scm_procedure_p (prot
)))
474 scm_array_fill_x (ra
, prot
);
476 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
477 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
478 return SCM_ARRAY_V (ra
);
485 scm_ra_set_contp (SCM ra
)
487 size_t k
= SCM_ARRAY_NDIM (ra
);
490 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
493 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
495 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
498 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
499 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
502 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
506 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
507 (SCM oldra
, SCM mapfunc
, SCM dims
),
508 "@code{make-shared-array} can be used to create shared subarrays of other\n"
509 "arrays. The @var{mapper} is a function that translates coordinates in\n"
510 "the new array into coordinates in the old array. A @var{mapper} must be\n"
511 "linear, and its range must stay within the bounds of the old array, but\n"
512 "it can be otherwise arbitrary. A simple example:\n"
514 "(define fred (make-array #f 8 8))\n"
515 "(define freds-diagonal\n"
516 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
517 "(array-set! freds-diagonal 'foo 3)\n"
518 "(array-ref fred 3 3) @result{} foo\n"
519 "(define freds-center\n"
520 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
521 "(array-ref freds-center 0 0) @result{} foo\n"
523 #define FUNC_NAME s_scm_make_shared_array
529 long old_min
, new_min
, old_max
, new_max
;
532 SCM_VALIDATE_REST_ARGUMENT (dims
);
533 SCM_VALIDATE_ARRAY (1, oldra
);
534 SCM_VALIDATE_PROC (2, mapfunc
);
535 ra
= scm_shap2ra (dims
, FUNC_NAME
);
536 if (SCM_ARRAYP (oldra
))
538 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
539 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
540 s
= SCM_ARRAY_DIMS (oldra
);
541 k
= SCM_ARRAY_NDIM (oldra
);
545 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
547 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
552 SCM_ARRAY_V (ra
) = oldra
;
554 old_max
= scm_to_long (scm_uniform_vector_length (oldra
)) - 1;
557 s
= SCM_ARRAY_DIMS (ra
);
558 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
560 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
561 if (s
[k
].ubnd
< s
[k
].lbnd
)
563 if (1 == SCM_ARRAY_NDIM (ra
))
564 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
566 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
570 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
571 if (SCM_ARRAYP (oldra
))
572 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
575 if (!scm_is_integer (imap
))
577 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
578 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
579 imap
= SCM_CAR (imap
);
581 i
= scm_to_size_t (imap
);
583 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
585 k
= SCM_ARRAY_NDIM (ra
);
588 if (s
[k
].ubnd
> s
[k
].lbnd
)
590 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
591 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
592 if (SCM_ARRAYP (oldra
))
594 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
597 if (!scm_is_integer (imap
))
599 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
600 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
601 imap
= SCM_CAR (imap
);
603 s
[k
].inc
= scm_to_long (imap
) - i
;
607 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
609 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
612 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
613 indptr
= SCM_CDR (indptr
);
615 if (old_min
> new_min
|| old_max
< new_max
)
616 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
617 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
619 SCM v
= SCM_ARRAY_V (ra
);
620 unsigned long int length
= scm_to_ulong (scm_uniform_vector_length (v
));
621 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
623 if (s
->ubnd
< s
->lbnd
)
624 return scm_make_uve (0L, scm_array_prototype (ra
));
626 scm_ra_set_contp (ra
);
632 /* args are RA . DIMS */
633 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
635 "Return an array sharing contents with @var{array}, but with\n"
636 "dimensions arranged in a different order. There must be one\n"
637 "@var{dim} argument for each dimension of @var{array}.\n"
638 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
639 "and the rank of the array to be returned. Each integer in that\n"
640 "range must appear at least once in the argument list.\n"
642 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
643 "dimensions in the array to be returned, their positions in the\n"
644 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
645 "may have the same value, in which case the returned array will\n"
646 "have smaller rank than @var{array}.\n"
649 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
650 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
651 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
652 " #2((a 4) (b 5) (c 6))\n"
654 #define FUNC_NAME s_scm_transpose_array
657 SCM
const *ve
= &vargs
;
658 scm_t_array_dim
*s
, *r
;
661 SCM_VALIDATE_REST_ARGUMENT (args
);
662 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
664 if (scm_is_generalized_vector (ra
))
666 /* Make sure that we are called with a single zero as
669 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
670 SCM_WRONG_NUM_ARGS ();
671 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
672 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
678 vargs
= scm_vector (args
);
679 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
680 SCM_WRONG_NUM_ARGS ();
681 ve
= SCM_VELTS (vargs
);
683 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
685 i
= scm_to_signed_integer (ve
[k
], 0, SCM_ARRAY_NDIM(ra
));
690 res
= scm_make_ra (ndim
);
691 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
692 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
695 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
696 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
698 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
700 i
= scm_to_int (ve
[k
]);
701 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
702 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
703 if (r
->ubnd
< r
->lbnd
)
712 if (r
->ubnd
> s
->ubnd
)
714 if (r
->lbnd
< s
->lbnd
)
716 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
723 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
724 scm_ra_set_contp (res
);
728 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
732 /* args are RA . AXES */
733 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
735 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
736 "the rank of @var{array}. @var{enclose-array} returns an array\n"
737 "resembling an array of shared arrays. The dimensions of each shared\n"
738 "array are the same as the @var{dim}th dimensions of the original array,\n"
739 "the dimensions of the outer array are the same as those of the original\n"
740 "array that did not match a @var{dim}.\n\n"
741 "An enclosed array is not a general Scheme array. Its elements may not\n"
742 "be set using @code{array-set!}. Two references to the same element of\n"
743 "an enclosed array will be @code{equal?} but will not in general be\n"
744 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
745 "enclosed array is unspecified.\n\n"
748 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
749 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
750 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
751 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
753 #define FUNC_NAME s_scm_enclose_array
755 SCM axv
, res
, ra_inr
;
757 scm_t_array_dim vdim
, *s
= &vdim
;
758 int ndim
, j
, k
, ninr
, noutr
;
760 SCM_VALIDATE_REST_ARGUMENT (axes
);
761 if (scm_is_null (axes
))
762 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
763 ninr
= scm_ilength (axes
);
765 SCM_WRONG_NUM_ARGS ();
766 ra_inr
= scm_make_ra (ninr
);
768 if (scm_is_generalized_vector (ra
))
771 s
->ubnd
= scm_to_long (scm_uniform_vector_length (ra
)) - 1;
773 SCM_ARRAY_V (ra_inr
) = ra
;
774 SCM_ARRAY_BASE (ra_inr
) = 0;
777 else if (SCM_ARRAYP (ra
))
779 s
= SCM_ARRAY_DIMS (ra
);
780 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
781 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
782 ndim
= SCM_ARRAY_NDIM (ra
);
785 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
789 SCM_WRONG_NUM_ARGS ();
790 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
791 res
= scm_make_ra (noutr
);
792 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
793 SCM_ARRAY_V (res
) = ra_inr
;
794 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
796 if (!scm_is_integer (SCM_CAR (axes
)))
797 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
798 j
= scm_to_int (SCM_CAR (axes
));
799 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
800 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
801 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
802 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
804 c_axv
= scm_i_string_chars (axv
);
805 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
809 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
810 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
811 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
813 scm_remember_upto_here_1 (axv
);
814 scm_ra_set_contp (ra_inr
);
815 scm_ra_set_contp (res
);
822 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
824 "Return @code{#t} if its arguments would be acceptable to\n"
826 #define FUNC_NAME s_scm_array_in_bounds_p
834 SCM_VALIDATE_REST_ARGUMENT (args
);
836 if (scm_is_pair (args
))
838 ind
= SCM_CAR (args
);
839 args
= SCM_CDR (args
);
840 pos
= scm_to_long (ind
);
844 if (scm_is_generalized_vector (v
))
846 size_t length
= scm_c_generalized_vector_length (v
);
847 SCM_ASRTGO (scm_is_null (args
) && scm_is_integer (ind
), wna
);
848 return scm_from_bool (pos
>= 0 && pos
< length
);
853 k
= SCM_ARRAY_NDIM (v
);
854 s
= SCM_ARRAY_DIMS (v
);
855 pos
= SCM_ARRAY_BASE (v
);
858 SCM_ASRTGO (scm_is_null (ind
), wna
);
864 j
= scm_to_long (ind
);
865 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
867 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
870 pos
+= (j
- s
->lbnd
) * (s
->inc
);
871 if (!(--k
&& SCM_NIMP (args
)))
873 ind
= SCM_CAR (args
);
874 args
= SCM_CDR (args
);
876 if (!scm_is_integer (ind
))
877 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
879 SCM_ASRTGO (0 == k
, wna
);
884 SCM_WRONG_NUM_ARGS ();
887 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
892 SCM_DEFINE (scm_array_ref
, "array-ref", 1, 0, 1,
894 "Return the element at the @code{(index1, index2)} element in\n"
896 #define FUNC_NAME s_scm_array_ref
902 SCM_ASRTGO (scm_is_null (args
), badarg
);
905 else if (SCM_ARRAYP (v
))
907 pos
= scm_aind (v
, args
, FUNC_NAME
);
915 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
916 pos
= scm_to_long (SCM_CAR (args
));
917 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
920 pos
= scm_to_long (args
);
921 length
= scm_c_generalized_vector_length (v
);
922 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
925 if (scm_is_generalized_vector (v
))
926 return scm_c_generalized_vector_ref (v
, pos
);
930 int k
= SCM_ARRAY_NDIM (v
);
931 SCM res
= scm_make_ra (k
);
932 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
933 SCM_ARRAY_BASE (res
) = pos
;
936 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
937 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
938 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
944 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
946 scm_wrong_num_args (NULL
);
948 scm_out_of_range (NULL
, scm_from_long (pos
));
952 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
953 tries to recycle conses. (Make *sure* you want them recycled.) */
956 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
958 if (scm_is_generalized_vector (v
))
959 return scm_c_generalized_vector_ref (v
, pos
);
962 { /* enclosed scm_array */
963 int k
= SCM_ARRAY_NDIM (v
);
964 SCM res
= scm_make_ra (k
);
965 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
966 SCM_ARRAY_BASE (res
) = pos
;
969 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
970 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
971 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
976 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
980 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
983 /* Note that args may be a list or an immediate object, depending which
984 PROC is used (and it's called from C too). */
985 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
986 (SCM v
, SCM obj
, SCM args
),
987 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
988 "@var{new-value}. The value returned by array-set! is unspecified.")
989 #define FUNC_NAME s_scm_array_set_x
995 pos
= scm_aind (v
, args
, FUNC_NAME
);
1001 if (scm_is_pair (args
))
1003 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1004 pos
= scm_to_long (SCM_CAR (args
));
1007 pos
= scm_to_long (args
);
1008 length
= scm_c_generalized_vector_length (v
);
1009 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1012 if (scm_is_generalized_vector (v
))
1014 scm_c_generalized_vector_set_x (v
, pos
, obj
);
1015 return SCM_UNSPECIFIED
;
1018 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1021 scm_out_of_range (NULL
, scm_from_long (pos
));
1023 scm_wrong_num_args (NULL
);
1027 /* attempts to unroll an array into a one-dimensional array.
1028 returns the unrolled array or #f if it can't be done. */
1029 /* if strict is not SCM_UNDEFINED, return #f if returned array
1030 wouldn't have contiguous elements. */
1031 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1032 (SCM ra
, SCM strict
),
1033 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1034 "without changing their order (last subscript changing fastest), then\n"
1035 "@code{array-contents} returns that shared array, otherwise it returns\n"
1036 "@code{#f}. All arrays made by @var{make-array} and\n"
1037 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1038 "@var{make-shared-array} may not be.\n\n"
1039 "If the optional argument @var{strict} is provided, a shared array will\n"
1040 "be returned only if its elements are stored internally contiguous in\n"
1042 #define FUNC_NAME s_scm_array_contents
1046 if (scm_is_generalized_vector (ra
))
1049 if (SCM_ARRAYP (ra
))
1051 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1052 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1054 for (k
= 0; k
< ndim
; k
++)
1055 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1056 if (!SCM_UNBNDP (strict
))
1058 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1060 if (scm_is_bitvector (SCM_ARRAY_V (ra
)))
1062 if (len
!= scm_c_bitvector_length (SCM_ARRAY_V (ra
)) ||
1063 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1070 SCM v
= SCM_ARRAY_V (ra
);
1071 size_t length
= scm_c_generalized_vector_length (v
);
1072 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1076 sra
= scm_make_ra (1);
1077 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1078 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1079 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1080 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1081 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1085 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
1091 scm_ra2contig (SCM ra
, int copy
)
1096 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1097 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1098 k
= SCM_ARRAY_NDIM (ra
);
1099 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1101 if (!scm_is_bitvector (SCM_ARRAY_V (ra
)))
1103 if ((len
== scm_c_bitvector_length (SCM_ARRAY_V (ra
)) &&
1104 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1105 0 == len
% SCM_LONG_BIT
))
1108 ret
= scm_make_ra (k
);
1109 SCM_ARRAY_BASE (ret
) = 0;
1112 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1113 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1114 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1115 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1117 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_prototype (ra
));
1119 scm_array_copy_x (ra
, ret
);
1125 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1126 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1127 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1128 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1129 "binary objects from @var{port-or-fdes}.\n"
1130 "If an end of file is encountered,\n"
1131 "the objects up to that point are put into @var{ura}\n"
1132 "(starting at the beginning) and the remainder of the array is\n"
1134 "The optional arguments @var{start} and @var{end} allow\n"
1135 "a specified region of a vector (or linearized array) to be read,\n"
1136 "leaving the remainder of the vector unchanged.\n\n"
1137 "@code{uniform-array-read!} returns the number of objects read.\n"
1138 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1139 "returned by @code{(current-input-port)}.")
1140 #define FUNC_NAME s_scm_uniform_array_read_x
1142 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1150 if (SCM_UNBNDP (port_or_fd
))
1151 port_or_fd
= scm_cur_inp
;
1153 SCM_ASSERT (scm_is_integer (port_or_fd
)
1154 || (SCM_OPINPORTP (port_or_fd
)),
1155 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1156 vlen
= (SCM_ARRAYP (v
) ?
1157 0 : scm_c_generalized_vector_length (v
));
1159 scm_frame_begin (0);
1162 if (scm_is_uniform_vector (v
))
1164 base
= scm_uniform_vector_elements (v
);
1165 sz
= scm_uniform_vector_element_size (v
);
1166 scm_frame_uniform_vector_release (v
);
1168 else if (scm_is_bitvector (v
))
1170 base
= (char *) scm_bitvector_elements (v
);
1171 scm_frame_bitvector_release (v
);
1172 vlen
= (vlen
+ 31) / 32;
1174 sz
= sizeof (scm_t_uint32
);
1176 else if (scm_is_string (v
))
1178 base
= NULL
; /* writing to strings is special, see below. */
1181 else if (SCM_ARRAYP (v
))
1183 cra
= scm_ra2contig (ra
, 0);
1184 cstart
+= SCM_ARRAY_BASE (cra
);
1185 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1186 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1187 v
= SCM_ARRAY_V (cra
);
1191 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1194 if (!SCM_UNBNDP (start
))
1197 SCM_NUM2LONG (3, start
);
1199 if (offset
< 0 || offset
>= cend
)
1200 scm_out_of_range (FUNC_NAME
, start
);
1202 if (!SCM_UNBNDP (end
))
1205 SCM_NUM2LONG (4, end
);
1207 if (tend
<= offset
|| tend
> cend
)
1208 scm_out_of_range (FUNC_NAME
, end
);
1213 if (SCM_NIMP (port_or_fd
))
1215 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1216 int remaining
= (cend
- offset
) * sz
;
1217 size_t off
= (cstart
+ offset
) * sz
;
1219 if (pt
->rw_active
== SCM_PORT_WRITE
)
1220 scm_flush (port_or_fd
);
1222 ans
= cend
- offset
;
1223 while (remaining
> 0)
1225 if (pt
->read_pos
< pt
->read_end
)
1227 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1233 char *b
= scm_i_string_writable_chars (v
);
1234 memcpy (b
+ off
, pt
->read_pos
, to_copy
);
1235 scm_i_string_stop_writing ();
1238 memcpy (base
+ off
, pt
->read_pos
, to_copy
);
1239 pt
->read_pos
+= to_copy
;
1240 remaining
-= to_copy
;
1245 if (scm_fill_input (port_or_fd
) == EOF
)
1247 if (remaining
% sz
!= 0)
1249 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1251 ans
-= remaining
/ sz
;
1258 pt
->rw_active
= SCM_PORT_READ
;
1260 else /* file descriptor. */
1265 char *b
= scm_i_string_writable_chars (v
);
1266 SCM_SYSCALL (ans
= read (scm_to_int (port_or_fd
),
1267 b
+ (cstart
+ offset
) * sz
,
1268 (sz
* (cend
- offset
))));
1269 scm_i_string_stop_writing ();
1272 SCM_SYSCALL (ans
= read (scm_to_int (port_or_fd
),
1273 base
+ (cstart
+ offset
) * sz
,
1274 (sz
* (cend
- offset
))));
1278 if (scm_is_bitvector (v
))
1281 if (!scm_is_eq (v
, ra
) && !scm_is_eq (cra
, ra
))
1282 scm_array_copy_x (cra
, ra
);
1286 return scm_from_long (ans
);
1290 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1291 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1292 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1293 "Writes all elements of @var{ura} as binary objects to\n"
1294 "@var{port-or-fdes}.\n\n"
1295 "The optional arguments @var{start}\n"
1296 "and @var{end} allow\n"
1297 "a specified region of a vector (or linearized array) to be written.\n\n"
1298 "The number of objects actually written is returned.\n"
1299 "@var{port-or-fdes} may be\n"
1300 "omitted, in which case it defaults to the value returned by\n"
1301 "@code{(current-output-port)}.")
1302 #define FUNC_NAME s_scm_uniform_array_write
1311 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1313 if (SCM_UNBNDP (port_or_fd
))
1314 port_or_fd
= scm_cur_outp
;
1316 SCM_ASSERT (scm_is_integer (port_or_fd
)
1317 || (SCM_OPOUTPORTP (port_or_fd
)),
1318 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1319 vlen
= (SCM_ARRAYP(v
)
1321 : scm_c_generalized_vector_length (v
));
1323 scm_frame_begin (0);
1326 if (scm_is_uniform_vector (v
))
1328 base
= scm_uniform_vector_elements (v
);
1329 sz
= scm_uniform_vector_element_size (v
);
1330 scm_frame_uniform_vector_release (v
);
1332 else if (scm_is_bitvector (v
))
1334 base
= (char *) scm_bitvector_elements (v
);
1335 scm_frame_bitvector_release (v
);
1336 vlen
= (vlen
+ 31) / 32;
1338 sz
= sizeof (scm_t_uint32
);
1340 else if (scm_is_string (v
))
1342 base
= scm_i_string_chars (v
);
1345 else if (SCM_ARRAYP (v
))
1347 v
= scm_ra2contig (v
, 1);
1348 cstart
= SCM_ARRAY_BASE (v
);
1349 vlen
= (SCM_ARRAY_DIMS (v
)->inc
1350 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1));
1351 v
= SCM_ARRAY_V (v
);
1355 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
1358 if (!SCM_UNBNDP (start
))
1361 SCM_NUM2LONG (3, start
);
1363 if (offset
< 0 || offset
>= cend
)
1364 scm_out_of_range (FUNC_NAME
, start
);
1366 if (!SCM_UNBNDP (end
))
1369 SCM_NUM2LONG (4, end
);
1371 if (tend
<= offset
|| tend
> cend
)
1372 scm_out_of_range (FUNC_NAME
, end
);
1377 if (SCM_NIMP (port_or_fd
))
1379 const char *source
= base
+ (cstart
+ offset
) * sz
;
1381 ans
= cend
- offset
;
1382 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1384 else /* file descriptor. */
1386 SCM_SYSCALL (ans
= write (scm_to_int (port_or_fd
),
1387 base
+ (cstart
+ offset
) * sz
,
1388 (sz
* (cend
- offset
))));
1392 if (scm_is_bitvector (v
))
1397 return scm_from_long (ans
);
1404 static scm_t_bits scm_tc16_bitvector
;
1406 #define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
1407 #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
1408 #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
1411 bitvector_free (SCM vec
)
1413 scm_gc_free (BITVECTOR_BITS (vec
),
1414 sizeof (scm_t_uint32
) * ((BITVECTOR_LENGTH (vec
)+31)/32),
1420 bitvector_print (SCM vec
, SCM port
, scm_print_state
*pstate
)
1422 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1423 size_t word_len
= (bit_len
+31)/32;
1424 scm_t_uint32
*bits
= BITVECTOR_BITS (vec
);
1427 scm_puts ("#*", port
);
1428 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1430 scm_t_uint32 mask
= 1;
1431 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1432 scm_putc ((bits
[i
] & mask
)? '1' : '0', port
);
1439 bitvector_equalp (SCM vec1
, SCM vec2
)
1441 size_t bit_len
= BITVECTOR_LENGTH (vec1
);
1442 size_t word_len
= (bit_len
+ 31) / 32;
1443 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1444 scm_t_uint32
*bits1
= BITVECTOR_BITS (vec1
);
1445 scm_t_uint32
*bits2
= BITVECTOR_BITS (vec2
);
1447 /* compare lengths */
1448 if (BITVECTOR_LENGTH (vec2
) != bit_len
)
1450 /* avoid underflow in word_len-1 below. */
1453 /* compare full words */
1454 if (memcmp (bits1
, bits2
, sizeof (scm_t_uint32
) * (word_len
-1)))
1456 /* compare partial last words */
1457 if ((bits1
[word_len
-1] & last_mask
) != (bits2
[word_len
-1] & last_mask
))
1463 scm_is_bitvector (SCM vec
)
1465 return IS_BITVECTOR (vec
);
1468 SCM_DEFINE (scm_bitvector_p
, "bitvector?", 1, 0, 0,
1470 "Return @code{#t} when @var{obj} is a bitvector, else\n"
1471 "return @code{#f}.")
1472 #define FUNC_NAME s_scm_bitvector_p
1474 return scm_from_bool (scm_is_bitvector (obj
));
1479 scm_c_make_bitvector (size_t len
, SCM fill
)
1481 size_t word_len
= (len
+ 31) / 32;
1485 bits
= scm_gc_malloc (sizeof (scm_t_uint32
) * word_len
,
1487 SCM_NEWSMOB2 (res
, scm_tc16_bitvector
, bits
, len
);
1489 if (!SCM_UNBNDP (fill
))
1490 scm_bitvector_fill_x (res
, fill
);
1495 SCM_DEFINE (scm_make_bitvector
, "make-bitvector", 1, 1, 0,
1496 (SCM len
, SCM fill
),
1497 "Create a new bitvector of length @var{len} and\n"
1498 "optionally initialize all elements to @var{fill}.")
1499 #define FUNC_NAME s_scm_make_bitvector
1501 return scm_c_make_bitvector (scm_to_size_t (len
), fill
);
1505 SCM_DEFINE (scm_bitvector
, "bitvector", 0, 0, 1,
1507 "Create a new bitvector with the arguments as elements.")
1508 #define FUNC_NAME s_scm_bitvector
1510 return scm_list_to_bitvector (bits
);
1515 scm_c_bitvector_length (SCM vec
)
1517 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1518 return BITVECTOR_LENGTH (vec
);
1521 SCM_DEFINE (scm_bitvector_length
, "bitvector-length", 1, 0, 0,
1523 "Return the length of the bitvector @var{vec}.")
1524 #define FUNC_NAME s_scm_bitvector_length
1526 return scm_from_size_t (scm_c_bitvector_length (vec
));
1531 scm_bitvector_elements (SCM vec
)
1533 scm_assert_smob_type (scm_tc16_bitvector
, vec
);
1534 return BITVECTOR_BITS (vec
);
1538 scm_bitvector_release (SCM vec
)
1540 /* Nothing to do right now, but this function might come in handy
1541 when bitvectors need to be locked when giving away a pointer
1544 Also, a call to scm_bitvector_release acts like
1545 scm_remember_upto_here, which is needed in any case.
1550 scm_frame_bitvector_release (SCM vec
)
1552 scm_frame_unwind_handler_with_scm (scm_bitvector_release
, vec
,
1553 SCM_F_WIND_EXPLICITLY
);
1557 scm_c_bitvector_ref (SCM vec
, size_t idx
)
1559 if (idx
< scm_c_bitvector_length (vec
))
1561 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1562 SCM res
= (bits
[idx
/32] & (1L << (idx
%32)))? SCM_BOOL_T
: SCM_BOOL_F
;
1563 scm_bitvector_release (vec
);
1567 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1570 SCM_DEFINE (scm_bitvector_ref
, "bitvector-ref", 2, 0, 0,
1572 "Return the element at index @var{idx} of the bitvector\n"
1574 #define FUNC_NAME s_scm_bitvector_ref
1576 return scm_c_bitvector_ref (vec
, scm_to_size_t (idx
));
1581 scm_c_bitvector_set_x (SCM vec
, size_t idx
, SCM val
)
1583 if (idx
< scm_c_bitvector_length (vec
))
1585 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1586 scm_t_uint32 mask
= 1L << (idx
%32);
1587 if (scm_is_true (val
))
1588 bits
[idx
/32] |= mask
;
1590 bits
[idx
/32] &= ~mask
;
1591 scm_bitvector_release (vec
);
1594 scm_out_of_range (NULL
, scm_from_size_t (idx
));
1597 SCM_DEFINE (scm_bitvector_set_x
, "bitvector-set!", 3, 0, 0,
1598 (SCM vec
, SCM idx
, SCM val
),
1599 "Set the element at index @var{idx} of the bitvector\n"
1600 "@var{vec} when @var{val} is true, else clear it.")
1601 #define FUNC_NAME s_scm_bitvector_set_x
1603 scm_c_bitvector_set_x (vec
, scm_to_size_t (idx
), val
);
1604 return SCM_UNSPECIFIED
;
1608 SCM_DEFINE (scm_bitvector_fill_x
, "bitvector-fill!", 2, 0, 0,
1610 "Set all elements of the bitvector\n"
1611 "@var{vec} when @var{val} is true, else clear them.")
1612 #define FUNC_NAME s_scm_bitvector_fill_x
1614 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1615 size_t bit_len
= BITVECTOR_LENGTH (vec
);
1616 size_t word_len
= (bit_len
+ 31) / 32;
1617 memset (bits
, scm_is_true (val
)? -1:0, sizeof (scm_t_uint32
) * word_len
);
1618 scm_bitvector_release (vec
);
1619 return SCM_UNSPECIFIED
;
1623 SCM_DEFINE (scm_list_to_bitvector
, "list->bitvector", 1, 0, 0,
1625 "Return a new bitvector initialized with the elements\n"
1627 #define FUNC_NAME s_scm_list_to_bitvector
1629 size_t bit_len
= scm_to_size_t (scm_length (list
));
1630 SCM vec
= scm_c_make_bitvector (bit_len
, SCM_UNDEFINED
);
1631 size_t word_len
= (bit_len
+31)/32;
1632 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1635 for (i
= 0; i
< word_len
&& scm_is_pair (list
); i
++, bit_len
-= 32)
1637 scm_t_uint32 mask
= 1;
1639 for (j
= 0; j
< 32 && j
< bit_len
;
1640 j
++, mask
<<= 1, list
= SCM_CDR (list
))
1641 if (scm_is_true (SCM_CAR (list
)))
1645 scm_bitvector_release (vec
);
1650 SCM_DEFINE (scm_bitvector_to_list
, "bitvector->list", 1, 0, 0,
1652 "Return a new list initialized with the elements\n"
1653 "of the bitvector @var{vec}.")
1654 #define FUNC_NAME s_scm_bitvector_to_list
1656 size_t bit_len
= scm_c_bitvector_length (vec
);
1658 size_t word_len
= (bit_len
+31)/32;
1659 scm_t_uint32
*bits
= scm_bitvector_elements (vec
);
1662 for (i
= 0; i
< word_len
; i
++, bit_len
-= 32)
1664 scm_t_uint32 mask
= 1;
1665 for (j
= 0; j
< 32 && j
< bit_len
; j
++, mask
<<= 1)
1666 res
= scm_cons ((bits
[i
] & mask
)? SCM_BOOL_T
: SCM_BOOL_F
, res
);
1669 scm_bitvector_release (vec
);
1670 return scm_reverse_x (res
, SCM_EOL
);
1674 /* From mmix-arith.w by Knuth.
1676 Here's a fun way to count the number of bits in a tetrabyte.
1678 [This classical trick is called the ``Gillies--Miller method for
1679 sideways addition'' in {\sl The Preparation of Programs for an
1680 Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
1681 edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
1682 the tricks used here were suggested by Balbir Singh, Peter
1683 Rossmanith, and Stefan Schwoon.]
1687 count_ones (scm_t_uint32 x
)
1689 x
=x
-((x
>>1)&0x55555555);
1690 x
=(x
&0x33333333)+((x
>>2)&0x33333333);
1691 x
=(x
+(x
>>4))&0x0f0f0f0f;
1693 return (x
+(x
>>16)) & 0xff;
1696 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1697 (SCM b
, SCM bitvector
),
1698 "Return the number of occurrences of the boolean @var{b} in\n"
1700 #define FUNC_NAME s_scm_bit_count
1702 size_t bit_len
= scm_c_bitvector_length (bitvector
);
1703 size_t word_len
= (bit_len
+ 31) / 32;
1704 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1705 scm_t_uint32
*bits
= scm_bitvector_elements (bitvector
);
1707 int bit
= scm_to_bool (b
);
1708 size_t count
= 0, i
;
1713 for (i
= 0; i
< word_len
-1; i
++)
1714 count
+= count_ones (bits
[i
]);
1715 count
+= count_ones (bits
[i
] & last_mask
);
1717 scm_bitvector_release (bitvector
);
1718 return scm_from_size_t (bit
? count
: bit_len
-count
);
1722 /* returns 32 for x == 0.
1725 find_first_one (scm_t_uint32 x
)
1728 /* do a binary search in x. */
1729 if ((x
& 0xFFFF) == 0)
1730 x
>>= 16, pos
+= 16;
1731 if ((x
& 0xFF) == 0)
1742 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1743 (SCM item
, SCM v
, SCM k
),
1744 "Return the index of the first occurrance of @var{item} in bit\n"
1745 "vector @var{v}, starting from @var{k}. If there is no\n"
1746 "@var{item} entry between @var{k} and the end of\n"
1747 "@var{bitvector}, then return @code{#f}. For example,\n"
1750 "(bit-position #t #*000101 0) @result{} 3\n"
1751 "(bit-position #f #*0001111 3) @result{} #f\n"
1753 #define FUNC_NAME s_scm_bit_position
1755 size_t bit_len
= scm_c_bitvector_length (v
);
1756 size_t word_len
= (bit_len
+ 31) / 32;
1757 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1758 scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1759 size_t first_bit
= scm_to_unsigned_integer (k
, 0, bit_len
);
1760 size_t first_word
= first_bit
/ 32;
1761 scm_t_uint32 first_mask
= ((scm_t_uint32
)-1) << (first_bit
- 32*first_word
);
1764 int bit
= scm_to_bool (item
);
1766 SCM res
= SCM_BOOL_F
;
1771 for (i
= first_word
; i
< word_len
; i
++)
1773 w
= (bit
? bits
[i
] : ~bits
[i
]);
1774 if (i
== first_word
)
1776 if (i
== word_len
-1)
1780 res
= scm_from_size_t (32*i
+ find_first_one (w
));
1785 scm_bitvector_release (v
);
1790 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1791 (SCM v
, SCM kv
, SCM obj
),
1792 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1793 "selecting the entries to change. The return value is\n"
1796 "If @var{kv} is a bit vector, then those entries where it has\n"
1797 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1798 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1799 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1800 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1803 "(define bv #*01000010)\n"
1804 "(bit-set*! bv #*10010001 #t)\n"
1806 "@result{} #*11010011\n"
1809 "If @var{kv} is a u32vector, then its elements are\n"
1810 "indices into @var{v} which are set to @var{obj}.\n"
1813 "(define bv #*01000010)\n"
1814 "(bit-set*! bv #u32(5 2 7) #t)\n"
1816 "@result{} #*01100111\n"
1818 #define FUNC_NAME s_scm_bit_set_star_x
1820 if (scm_is_bitvector (kv
))
1822 size_t bit_len
= scm_c_bitvector_length (kv
);
1823 size_t word_len
= (bit_len
+ 31) / 32;
1824 scm_t_uint32
*bits1
, *bits2
;
1826 int bit
= scm_to_bool (obj
);
1828 if (scm_c_bitvector_length (v
) != bit_len
)
1829 scm_misc_error (NULL
,
1830 "bit vectors must have equal length",
1833 bits1
= scm_bitvector_elements (v
);
1834 bits2
= scm_bitvector_elements (kv
);
1837 for (i
= 0; i
< word_len
; i
++)
1838 bits1
[i
] &= ~bits2
[i
];
1840 for (i
= 0; i
< word_len
; i
++)
1841 bits1
[i
] |= bits2
[i
];
1843 scm_bitvector_release (kv
);
1844 scm_bitvector_release (v
);
1846 else if (scm_is_true (scm_u32vector_p (kv
)))
1849 scm_t_uint32
*indices
;
1851 /* assert that obj is a boolean.
1855 scm_frame_begin (0);
1857 ulen
= scm_c_uniform_vector_length (kv
);
1858 indices
= scm_u32vector_elements (kv
);
1859 scm_frame_uniform_vector_release (kv
);
1861 for (i
= 0; i
< ulen
; i
++)
1862 scm_c_bitvector_set_x (v
, (size_t)indices
[i
], obj
);
1867 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1869 return SCM_UNSPECIFIED
;
1874 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1875 (SCM v
, SCM kv
, SCM obj
),
1876 "Return a count of how many entries in bit vector @var{v} are\n"
1877 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1880 "If @var{kv} is a bit vector, then those entries where it has\n"
1881 "@code{#t} are the ones in @var{v} which are considered.\n"
1882 "@var{kv} and @var{v} must be the same length.\n"
1884 "If @var{kv} is a u32vector, then it contains\n"
1885 "the indexes in @var{v} to consider.\n"
1890 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1891 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
1893 #define FUNC_NAME s_scm_bit_count_star
1895 if (scm_is_bitvector (kv
))
1897 size_t bit_len
= scm_c_bitvector_length (kv
);
1898 size_t word_len
= (bit_len
+ 31) / 32;
1899 scm_t_uint32 last_mask
= ((scm_t_uint32
)-1) >> (32*word_len
- bit_len
);
1900 scm_t_uint32 xor_mask
= scm_to_bool (obj
)? 0 : ((scm_t_uint32
)-1);
1901 scm_t_uint32
*bits1
, *bits2
;
1902 size_t count
= 0, i
;
1904 if (scm_c_bitvector_length (v
) != bit_len
)
1905 scm_misc_error (NULL
,
1906 "bit vectors must have equal length",
1910 return scm_from_size_t (0);
1912 bits1
= scm_bitvector_elements (v
);
1913 bits2
= scm_bitvector_elements (kv
);
1915 for (i
= 0; i
< word_len
-1; i
++)
1916 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
]);
1917 count
+= count_ones ((bits1
[i
]^xor_mask
) & bits2
[i
] & last_mask
);
1919 scm_bitvector_release (kv
);
1920 scm_bitvector_release (v
);
1922 return scm_from_size_t (count
);
1924 else if (scm_is_true (scm_u32vector_p (kv
)))
1926 size_t count
= 0, ulen
, i
;
1927 scm_t_uint32
*indices
;
1928 int bit
= scm_to_bool (obj
);
1930 scm_frame_begin (0);
1932 ulen
= scm_c_uniform_vector_length (kv
);
1933 indices
= scm_u32vector_elements (kv
);
1934 scm_frame_uniform_vector_release (kv
);
1936 for (i
= 0; i
< ulen
; i
++)
1937 if ((scm_is_true (scm_c_bitvector_ref (v
, (size_t)indices
[i
])) != 0)
1943 return scm_from_size_t (count
);
1946 scm_wrong_type_arg_msg (NULL
, 0, kv
, "bitvector or u32vector");
1951 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1953 "Modify the bit vector @var{v} by replacing each element with\n"
1955 #define FUNC_NAME s_scm_bit_invert_x
1957 size_t bit_len
= scm_c_bitvector_length (v
);
1958 size_t word_len
= (bit_len
+ 31) / 32;
1959 scm_t_uint32
*bits
= scm_bitvector_elements (v
);
1962 for (i
= 0; i
< word_len
; i
++)
1965 scm_bitvector_release (v
);
1966 return SCM_UNSPECIFIED
;
1972 scm_istr2bve (SCM str
)
1974 size_t len
= scm_i_string_length (str
);
1975 SCM vec
= scm_c_make_bitvector (len
, SCM_UNDEFINED
);
1980 const char *c_str
= scm_i_string_chars (str
);
1981 scm_t_uint32
*data
= scm_bitvector_elements (vec
);
1983 for (k
= 0; k
< (len
+ 31) / 32; k
++)
1989 for (mask
= 1L; j
--; mask
<<= 1)
2004 scm_remember_upto_here_1 (str
);
2005 scm_bitvector_release (vec
);
2012 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2014 register SCM res
= SCM_EOL
;
2015 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2017 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2019 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2020 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2025 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2033 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), scm_from_size_t (i
)), res
);
2040 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2042 "Return a list consisting of all the elements, in order, of\n"
2044 #define FUNC_NAME s_scm_array_to_list
2046 if (scm_is_generalized_vector (v
))
2047 return scm_generalized_vector_to_list (v
);
2048 else if (SCM_ARRAYP (v
))
2049 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2051 scm_wrong_type_arg_msg (NULL
, 0, v
, "array");
2056 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2058 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2059 (SCM ndim
, SCM prot
, SCM lst
),
2060 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2061 "Return a uniform array of the type indicated by prototype\n"
2062 "@var{prot} with elements the same as those of @var{lst}.\n"
2063 "Elements must be of the appropriate type, no coercions are\n"
2066 "The argument @var{ndim} determines the number of dimensions\n"
2067 "of the array. It is either an exact integer, giving the\n"
2068 "number directly, or a list of exact integers, whose length\n"
2069 "specifies the number of dimensions and each element is the\n"
2070 "lower index bound of its dimension.")
2071 #define FUNC_NAME s_scm_list_to_uniform_array
2079 if (scm_is_integer (ndim
))
2081 size_t k
= scm_to_size_t (ndim
);
2084 shape
= scm_cons (scm_length (row
), shape
);
2086 row
= scm_car (row
);
2093 shape
= scm_cons (scm_list_2 (scm_car (ndim
),
2094 scm_sum (scm_sum (scm_car (ndim
),
2096 scm_from_int (-1))),
2098 ndim
= scm_cdr (ndim
);
2099 if (scm_is_pair (ndim
))
2100 row
= scm_car (row
);
2106 ra
= scm_dimensions_to_uniform_array (scm_reverse_x (shape
, SCM_EOL
), prot
,
2109 if (scm_is_null (shape
))
2111 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2112 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2115 if (!SCM_ARRAYP (ra
))
2117 size_t length
= scm_c_generalized_vector_length (ra
);
2118 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2119 scm_c_generalized_vector_set_x (ra
, k
, SCM_CAR (lst
));
2122 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2125 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2131 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2133 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2134 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2137 return (scm_is_null (lst
));
2138 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2142 if (!scm_is_pair (lst
))
2144 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2146 lst
= SCM_CDR (lst
);
2148 if (!scm_is_null (lst
))
2155 if (!scm_is_pair (lst
))
2157 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
2159 lst
= SCM_CDR (lst
);
2161 if (!scm_is_null (lst
))
2169 rapr1 (SCM ra
, unsigned long j
, unsigned long k
, SCM port
, scm_print_state
*pstate
)
2172 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2174 : scm_to_long (scm_uniform_vector_length (ra
)));
2177 switch SCM_TYP7 (ra
)
2182 SCM_ARRAY_BASE (ra
) = j
;
2184 scm_iprin1 (ra
, port
, pstate
);
2185 for (j
+= inc
; n
-- > 0; j
+= inc
)
2187 scm_putc (' ', port
);
2188 SCM_ARRAY_BASE (ra
) = j
;
2189 scm_iprin1 (ra
, port
, pstate
);
2193 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2196 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2197 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2199 scm_putc ('(', port
);
2200 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2201 scm_puts (") ", port
);
2204 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2205 { /* could be zero size. */
2206 scm_putc ('(', port
);
2207 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2208 scm_putc (')', port
);
2212 if (SCM_ARRAY_NDIM (ra
) > 0)
2213 { /* Could be zero-dimensional */
2214 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2215 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2219 ra
= SCM_ARRAY_V (ra
);
2222 /* scm_tc7_bvect and scm_tc7_llvect only? */
2224 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2225 for (j
+= inc
; n
-- > 0; j
+= inc
)
2227 scm_putc (' ', port
);
2228 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2231 case scm_tc7_string
:
2234 src
= scm_i_string_chars (ra
);
2236 scm_iprin1 (SCM_MAKE_CHAR (src
[j
]), port
, pstate
);
2237 if (SCM_WRITINGP (pstate
))
2238 for (j
+= inc
; n
-- > 0; j
+= inc
)
2240 scm_putc (' ', port
);
2241 scm_iprin1 (SCM_MAKE_CHAR (src
[j
]), port
, pstate
);
2244 for (j
+= inc
; n
-- > 0; j
+= inc
)
2245 scm_putc (src
[j
], port
);
2246 scm_remember_upto_here_1 (ra
);
2253 /* Print dimension DIM of ARRAY.
2257 scm_i_print_array_dimension (SCM array
, int dim
, int base
,
2258 SCM port
, scm_print_state
*pstate
)
2260 scm_t_array_dim
*dim_spec
= SCM_ARRAY_DIMS (array
) + dim
;
2263 scm_putc ('(', port
);
2266 scm_putc ('{', port
);
2267 scm_intprint (dim_spec
->lbnd
, 10, port
);
2268 scm_putc (':', port
);
2269 scm_intprint (dim_spec
->ubnd
, 10, port
);
2270 scm_putc (':', port
);
2271 scm_intprint (dim_spec
->inc
, 10, port
);
2272 scm_putc ('}', port
);
2275 for (idx
= dim_spec
->lbnd
; idx
<= dim_spec
->ubnd
; idx
++)
2277 if (dim
< SCM_ARRAY_NDIM(array
)-1)
2278 scm_i_print_array_dimension (array
, dim
+1, base
, port
, pstate
);
2280 scm_iprin1 (scm_cvref (SCM_ARRAY_V (array
), base
, SCM_UNDEFINED
),
2282 if (idx
< dim_spec
->ubnd
)
2283 scm_putc (' ', port
);
2284 base
+= dim_spec
->inc
;
2287 scm_putc (')', port
);
2291 /* Print an array. (Only for strict arrays, not for strings, uniform
2292 vectors, vectors and other stuff that can masquerade as an array.)
2295 /* The array tag is generally of the form
2297 * #<rank><unif><@lower><@lower>...
2299 * <rank> is a positive integer in decimal giving the rank of the
2300 * array. It is omitted when the rank is 1 and the array is
2301 * non-shared and has zero-origin. For shared arrays and for a
2302 * non-zero origin, the rank is always printed even when it is 1 to
2303 * dinstinguish them from ordinary vectors.
2305 * <unif> is the tag for a uniform (or homogenous) numeric vector,
2306 * like u8, s16, etc, as defined by SRFI-4. It is omitted when the
2307 * array is not uniform.
2309 * <@lower> is a 'at' sign followed by a integer in decimal giving the
2310 * lower bound of a dimension. There is one <@lower> for each
2311 * dimension. When all lower bounds are zero, all <@lower> are
2316 * #(1 2 3) is non-uniform array of rank 1 with lower bound 0 in
2317 * dimension 0. (I.e., a regular vector.)
2319 * #@2(1 2 3) is non-uniform array of rank 1 with lower bound 2 in
2322 * #2((1 2 3) (4 5 6)) is a non-uniform array of rank 2; a 3x3
2323 * matrix with index ranges 0..2 and 0..2.
2325 * #u32(0 1 2) is a uniform u8 array of rank 1.
2327 * #2u32@2@3((1 2) (2 3)) is a uniform u8 array of rank 2 with index
2328 * ranges 2..3 and 3..4.
2332 scm_i_print_array (SCM array
, SCM port
, scm_print_state
*pstate
)
2334 long ndim
= SCM_ARRAY_NDIM (array
);
2335 scm_t_array_dim
*dim_specs
= SCM_ARRAY_DIMS (array
);
2336 SCM v
= SCM_ARRAY_V (array
);
2337 unsigned long base
= SCM_ARRAY_BASE (array
);
2340 scm_putc ('#', port
);
2341 if (ndim
!= 1 || dim_specs
[0].lbnd
!= 0)
2342 scm_intprint (ndim
, 10, port
);
2343 if (scm_is_uniform_vector (v
))
2344 scm_puts (scm_i_uniform_vector_tag (v
), port
);
2345 else if (scm_is_bitvector (v
))
2346 scm_puts ("b", port
);
2347 else if (scm_is_string (v
))
2348 scm_puts ("a", port
);
2349 else if (!scm_is_vector (v
))
2350 scm_puts ("?", port
);
2352 for (i
= 0; i
< ndim
; i
++)
2353 if (dim_specs
[i
].lbnd
!= 0)
2355 for (i
= 0; i
< ndim
; i
++)
2357 scm_putc ('@', port
);
2358 scm_uintprint (dim_specs
[i
].lbnd
, 10, port
);
2363 return scm_i_print_array_dimension (array
, 0, base
, port
, pstate
);
2366 /* Read an array. This function can also read vectors and uniform
2367 vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
2370 C is the first character read after the '#'.
2378 static tag_proto tag_proto_table
[] = {
2379 { "", &scm_i_proc_make_vector
},
2380 { "u8", &scm_i_proc_make_u8vector
},
2381 { "s8", &scm_i_proc_make_s8vector
},
2382 { "u16", &scm_i_proc_make_u16vector
},
2383 { "s16", &scm_i_proc_make_s16vector
},
2384 { "u32", &scm_i_proc_make_u32vector
},
2385 { "s32", &scm_i_proc_make_s32vector
},
2386 { "u64", &scm_i_proc_make_u64vector
},
2387 { "s64", &scm_i_proc_make_s64vector
},
2388 { "f32", &scm_i_proc_make_f32vector
},
2389 { "f64", &scm_i_proc_make_f64vector
},
2394 scm_i_tag_to_prototype (const char *tag
, SCM port
)
2398 for (tp
= tag_proto_table
; tp
->tag
; tp
++)
2399 if (!strcmp (tp
->tag
, tag
))
2400 return *(tp
->proto_var
);
2402 #if SCM_ENABLE_DEPRECATED
2404 /* Recognize the old syntax, producing the old prototypes.
2406 SCM proto
= SCM_EOL
;
2407 const char *instead
;
2411 proto
= SCM_MAKE_CHAR ('a');
2415 proto
= scm_from_int (1);
2419 proto
= scm_from_int (-1);
2423 proto
= scm_from_double (1.0);
2427 proto
= scm_divide (scm_from_int (1), scm_from_int (3));
2431 proto
= SCM_MAKE_CHAR (0);
2435 proto
= scm_from_locale_symbol ("s");
2439 proto
= scm_from_locale_symbol ("l");
2443 proto
= scm_c_make_rectangular (0.0, 1.0);
2450 if (!scm_is_eq (proto
, SCM_EOL
) && tag
[1] == '\0')
2452 scm_c_issue_deprecation_warning_fmt
2453 ("The tag '%c' is deprecated for uniform vectors. "
2454 "Use '%s' instead.", tag
[0], instead
);
2460 scm_i_input_error (NULL
, port
,
2461 "unrecognized uniform array tag: ~a",
2462 scm_list_1 (scm_from_locale_string (tag
)));
2467 scm_i_read_array (SCM port
, int c
)
2474 SCM lower_bounds
, elements
;
2476 /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
2477 the array code can not deal with zero-length dimensions yet, and
2478 we want to allow zero-length vectors, of course.
2482 scm_ungetc (c
, port
);
2483 return scm_vector (scm_read (port
));
2486 /* Disambiguate between '#f' and uniform floating point vectors.
2490 c
= scm_getc (port
);
2491 if (c
!= '3' && c
!= '6')
2494 scm_ungetc (c
, port
);
2501 goto continue_reading_tag
;
2504 /* Read rank. We disallow arrays of rank zero since they do not
2505 seem to work reliably yet. */
2508 while ('0' <= c
&& c
<= '9')
2510 rank
= 10*rank
+ c
-'0';
2512 c
= scm_getc (port
);
2517 scm_i_input_error (NULL
, port
,
2518 "array rank must be positive", SCM_EOL
);
2522 continue_reading_tag
:
2523 while (c
!= EOF
&& c
!= '(' && c
!= '@' && tag_len
< 80)
2526 c
= scm_getc (port
);
2528 tag
[tag_len
] = '\0';
2530 /* Read lower bounds. */
2531 lower_bounds
= SCM_EOL
;
2534 /* Yeah, right, we should use some ready-made integer parsing
2541 c
= scm_getc (port
);
2545 c
= scm_getc (port
);
2547 while ('0' <= c
&& c
<= '9')
2549 lbnd
= 10*lbnd
+ c
-'0';
2550 c
= scm_getc (port
);
2552 lower_bounds
= scm_cons (scm_from_long (sign
*lbnd
), lower_bounds
);
2555 /* Read nested lists of elements.
2558 scm_i_input_error (NULL
, port
,
2559 "missing '(' in vector or array literal",
2561 scm_ungetc (c
, port
);
2562 elements
= scm_read (port
);
2564 if (scm_is_null (lower_bounds
))
2565 lower_bounds
= scm_from_size_t (rank
);
2566 else if (scm_ilength (lower_bounds
) != rank
)
2567 scm_i_input_error (NULL
, port
,
2568 "the number of lower bounds must match the array rank",
2571 /* Construct array. */
2572 return scm_list_to_uniform_array (lower_bounds
,
2573 scm_i_tag_to_prototype (tag
, port
),
2578 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2581 unsigned long base
= 0;
2584 if (SCM_ARRAYP (exp
) && !SCM_ARRAYP (SCM_ARRAY_V (exp
)))
2585 return scm_i_print_array (exp
, port
, pstate
);
2587 scm_putc ('#', port
);
2588 ndim
= SCM_ARRAY_NDIM (v
);
2589 base
= SCM_ARRAY_BASE (v
);
2590 v
= SCM_ARRAY_V (v
);
2591 scm_puts ("<enclosed-array ", port
);
2592 rapr1 (exp
, base
, 0, port
, pstate
);
2593 scm_putc ('>', port
);
2597 SCM_DEFINE (scm_array_creator
, "array-creator", 1, 0, 0,
2599 "Return a procedure that would produce an array of the same type\n"
2600 "as @var{array}, if used as the @var{creator} with\n"
2601 "@code{make-uniform-array}.")
2602 #define FUNC_NAME s_scm_array_creator
2607 if (SCM_ARRAYP (ra
))
2609 ra
= SCM_ARRAY_V (ra
);
2613 if (scm_is_generalized_vector (ra
))
2614 return scm_i_generalized_vector_creator (ra
);
2615 else if (SCM_ARRAYP (ra
))
2616 scm_misc_error (NULL
, "creator not known for enclosed array: ~a",
2617 scm_list_1 (orig_ra
));
2619 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2621 scm_misc_error (NULL
, "creator not known for array content: ~a",
2626 #if SCM_ENABLE_DEPRECATED
2628 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2630 "Return an object that would produce an array of the same type\n"
2631 "as @var{array}, if used as the @var{prototype} for\n"
2632 "@code{make-uniform-array}.")
2633 #define FUNC_NAME s_scm_array_prototype
2638 if (SCM_ARRAYP (ra
))
2641 return SCM_UNSPECIFIED
;
2642 ra
= SCM_ARRAY_V (ra
);
2645 else if (scm_is_generalized_vector (ra
))
2646 return scm_i_get_old_prototype (ra
);
2648 scm_wrong_type_arg_msg (NULL
, 0, ra
, "array");
2655 array_mark (SCM ptr
)
2657 return SCM_ARRAY_V (ptr
);
2662 array_free (SCM ptr
)
2664 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2665 (sizeof (scm_t_array
)
2666 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2674 scm_tc16_array
= scm_make_smob_type ("array", 0);
2675 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2676 scm_set_smob_free (scm_tc16_array
, array_free
);
2677 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2678 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2679 exactly_one_third
= scm_permanent_object (scm_divide (scm_from_int (1),
2681 scm_add_feature ("array");
2683 scm_tc16_bitvector
= scm_make_smob_type ("bitvector", 0);
2684 scm_set_smob_free (scm_tc16_bitvector
, bitvector_free
);
2685 scm_set_smob_print (scm_tc16_bitvector
, bitvector_print
);
2686 scm_set_smob_equalp (scm_tc16_bitvector
, bitvector_equalp
);
2688 #include "libguile/unif.x"
2690 scm_i_proc_make_vector
= scm_variable_ref (scm_c_lookup ("make-vector"));
2691 scm_i_proc_make_string
= scm_variable_ref (scm_c_lookup ("make-string"));
2692 scm_i_proc_make_bitvector
=
2693 scm_variable_ref (scm_c_lookup ("make-bitvector"));