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/chars.h"
38 #include "libguile/eval.h"
39 #include "libguile/fports.h"
40 #include "libguile/smob.h"
41 #include "libguile/feature.h"
42 #include "libguile/root.h"
43 #include "libguile/strings.h"
44 #include "libguile/srfi-13.h"
45 #include "libguile/vectors.h"
47 #include "libguile/validate.h"
48 #include "libguile/unif.h"
49 #include "libguile/ramap.h"
60 /* The set of uniform scm_vector types is:
62 * unsigned char string
69 * complex double cvect
74 scm_t_bits scm_tc16_array
;
75 static SCM exactly_one_third
;
77 /* return the size of an element in a uniform array or 0 if type not
80 scm_uniform_element_size (SCM obj
)
84 switch (SCM_TYP7 (obj
))
89 result
= sizeof (long);
93 result
= sizeof (char);
97 result
= sizeof (short);
100 #if SCM_SIZEOF_LONG_LONG != 0
102 result
= sizeof (long long);
107 result
= sizeof (float);
111 result
= sizeof (double);
115 result
= 2 * sizeof (double);
124 /* Silly function used not to modify the semantics of the silly
125 * prototype system in order to be backward compatible.
130 if (!SCM_REALP (obj
))
134 double x
= SCM_REAL_VALUE (obj
);
136 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
141 make_uve (long type
, long k
, size_t size
)
142 #define FUNC_NAME "scm_make_uve"
144 SCM_ASSERT_RANGE (1, scm_from_long (k
), k
<= SCM_UVECTOR_MAX_LENGTH
);
146 return scm_cell (SCM_MAKE_UVECTOR_TAG (k
, type
),
147 (scm_t_bits
) scm_gc_malloc (k
* size
, "vector"));
152 scm_make_uve (long k
, SCM prot
)
153 #define FUNC_NAME "scm_make_uve"
155 if (scm_is_eq (prot
, SCM_BOOL_T
))
160 SCM_ASSERT_RANGE (1, scm_from_long (k
),
161 k
<= SCM_BITVECTOR_MAX_LENGTH
);
162 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
163 return scm_cell (SCM_MAKE_BITVECTOR_TAG (k
),
164 (scm_t_bits
) scm_gc_malloc (i
, "vector"));
167 return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
169 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
170 return make_uve (scm_tc7_byvect
, k
, sizeof (char));
171 else if (SCM_CHARP (prot
))
172 return scm_c_make_string (sizeof (char) * k
, SCM_UNDEFINED
);
173 else if (SCM_I_INUMP (prot
))
174 return make_uve (SCM_I_INUM (prot
) > 0 ? scm_tc7_uvect
: scm_tc7_ivect
,
177 else if (SCM_FRACTIONP (prot
))
179 if (scm_num_eq_p (exactly_one_third
, prot
))
182 else if (scm_is_symbol (prot
) && (1 == scm_i_symbol_length (prot
)))
186 s
= scm_i_symbol_chars (prot
)[0];
188 return make_uve (scm_tc7_svect
, k
, sizeof (short));
189 #if SCM_SIZEOF_LONG_LONG != 0
191 return make_uve (scm_tc7_llvect
, k
, sizeof (long long));
194 return scm_c_make_vector (k
, SCM_UNDEFINED
);
196 else if (!SCM_INEXACTP (prot
))
197 /* Huge non-unif vectors are NOT supported. */
198 /* no special scm_vector */
199 return scm_c_make_vector (k
, SCM_UNDEFINED
);
200 else if (singp (prot
))
201 return make_uve (scm_tc7_fvect
, k
, sizeof (float));
202 else if (SCM_COMPLEXP (prot
))
203 return make_uve (scm_tc7_cvect
, k
, 2 * sizeof (double));
205 return make_uve (scm_tc7_dvect
, k
, sizeof (double));
209 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
211 "Return the number of elements in @var{uve}.")
212 #define FUNC_NAME s_scm_uniform_vector_length
214 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
218 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
221 return scm_from_size_t (SCM_VECTOR_LENGTH (v
));
223 return scm_from_size_t (scm_i_string_length (v
));
225 return scm_from_size_t (SCM_BITVECTOR_LENGTH (v
));
233 #if SCM_SIZEOF_LONG_LONG != 0
236 return scm_from_size_t (SCM_UVECTOR_LENGTH (v
));
241 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
243 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
244 "not. The @var{prototype} argument is used with uniform arrays\n"
245 "and is described elsewhere.")
246 #define FUNC_NAME s_scm_array_p
250 nprot
= SCM_UNBNDP (prot
);
255 while (SCM_TYP7 (v
) == scm_tc7_smob
)
266 return scm_from_bool(nprot
);
271 switch (SCM_TYP7 (v
))
274 protp
= (scm_is_eq (prot
, SCM_BOOL_T
));
277 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
280 protp
= scm_is_eq (prot
, SCM_MAKE_CHAR ('\0'));
283 protp
= SCM_I_INUMP(prot
) && SCM_I_INUM(prot
)>0;
286 protp
= SCM_I_INUMP(prot
) && SCM_I_INUM(prot
)<=0;
289 protp
= scm_is_symbol (prot
)
290 && (1 == scm_i_symbol_length (prot
))
291 && ('s' == scm_i_symbol_chars (prot
)[0]);
293 #if SCM_SIZEOF_LONG_LONG != 0
295 protp
= scm_is_symbol (prot
)
296 && (1 == scm_i_symbol_length (prot
))
297 && ('l' == scm_i_symbol_chars (prot
)[0]);
301 protp
= singp (prot
);
304 protp
= ((SCM_REALP(prot
) && ! singp (prot
))
305 || (SCM_FRACTIONP (prot
)
306 && scm_num_eq_p (exactly_one_third
, prot
)));
309 protp
= SCM_COMPLEXP(prot
);
313 protp
= scm_is_null(prot
);
319 return scm_from_bool(protp
);
325 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
327 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
328 "not an array, @code{0} is returned.")
329 #define FUNC_NAME s_scm_array_rank
333 switch (SCM_TYP7 (ra
))
346 #if SCM_SIZEOF_LONG_LONG != 0
350 return scm_from_int (1);
353 return scm_from_size_t (SCM_ARRAY_NDIM (ra
));
360 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
362 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
363 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
365 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
367 #define FUNC_NAME s_scm_array_dimensions
374 switch (SCM_TYP7 (ra
))
389 #if SCM_SIZEOF_LONG_LONG != 0
392 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
394 if (!SCM_ARRAYP (ra
))
396 k
= SCM_ARRAY_NDIM (ra
);
397 s
= SCM_ARRAY_DIMS (ra
);
399 res
= scm_cons (s
[k
].lbnd
400 ? scm_cons2 (scm_from_long (s
[k
].lbnd
),
401 scm_from_long (s
[k
].ubnd
),
403 : scm_from_long (1 + s
[k
].ubnd
),
411 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
413 "Return the root vector of a shared array.")
414 #define FUNC_NAME s_scm_shared_array_root
416 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
417 return SCM_ARRAY_V (ra
);
422 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
424 "Return the root vector index of the first element in the array.")
425 #define FUNC_NAME s_scm_shared_array_offset
427 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
428 return scm_from_int (SCM_ARRAY_BASE (ra
));
433 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
435 "For each dimension, return the distance between elements in the root vector.")
436 #define FUNC_NAME s_scm_shared_array_increments
441 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
442 k
= SCM_ARRAY_NDIM (ra
);
443 s
= SCM_ARRAY_DIMS (ra
);
445 res
= scm_cons (scm_from_long (s
[k
].inc
), res
);
451 static char s_bad_ind
[] = "Bad scm_array index";
455 scm_aind (SCM ra
, SCM args
, const char *what
)
456 #define FUNC_NAME what
460 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
461 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
462 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
463 if (scm_is_integer (args
))
466 scm_error_num_args_subr (what
);
467 return pos
+ (scm_to_long (args
) - s
->lbnd
) * (s
->inc
);
469 while (k
&& scm_is_pair (args
))
471 ind
= SCM_CAR (args
);
472 args
= SCM_CDR (args
);
473 if (!scm_is_integer (ind
))
474 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
475 j
= scm_to_long (ind
);
476 if (j
< s
->lbnd
|| j
> s
->ubnd
)
477 scm_out_of_range (what
, ind
);
478 pos
+= (j
- s
->lbnd
) * (s
->inc
);
482 if (k
!= 0 || !scm_is_null (args
))
483 scm_error_num_args_subr (what
);
491 scm_make_ra (int ndim
)
495 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_tc16_array
,
496 scm_gc_malloc ((sizeof (scm_t_array
) +
497 ndim
* sizeof (scm_t_array_dim
)),
499 SCM_ARRAY_V (ra
) = scm_nullvect
;
504 static char s_bad_spec
[] = "Bad scm_array dimension";
505 /* Increments will still need to be set. */
509 scm_shap2ra (SCM args
, const char *what
)
513 int ndim
= scm_ilength (args
);
515 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
517 ra
= scm_make_ra (ndim
);
518 SCM_ARRAY_BASE (ra
) = 0;
519 s
= SCM_ARRAY_DIMS (ra
);
520 for (; !scm_is_null (args
); s
++, args
= SCM_CDR (args
))
522 spec
= SCM_CAR (args
);
523 if (scm_is_integer (spec
))
525 if (scm_to_long (spec
) < 0)
526 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
528 s
->ubnd
= scm_to_long (spec
) - 1;
533 if (!scm_is_pair (spec
) || !scm_is_integer (SCM_CAR (spec
)))
534 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
535 s
->lbnd
= scm_to_long (SCM_CAR (spec
));
537 if (!scm_is_pair (sp
)
538 || !scm_is_integer (SCM_CAR (sp
))
539 || !scm_is_null (SCM_CDR (sp
)))
540 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
541 s
->ubnd
= scm_to_long (SCM_CAR (sp
));
548 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
549 (SCM dims
, SCM prot
, SCM fill
),
550 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
551 "Create and return a uniform array or vector of type\n"
552 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
553 "length @var{length}. If @var{fill} is supplied, it's used to\n"
554 "fill the array, otherwise @var{prototype} is used.")
555 #define FUNC_NAME s_scm_dimensions_to_uniform_array
558 unsigned long rlen
= 1;
562 if (scm_is_integer (dims
))
564 SCM answer
= scm_make_uve (scm_to_long (dims
), prot
);
565 if (!SCM_UNBNDP (fill
))
566 scm_array_fill_x (answer
, fill
);
567 else if (scm_is_symbol (prot
))
568 scm_array_fill_x (answer
, scm_from_int (0));
570 scm_array_fill_x (answer
, prot
);
574 SCM_ASSERT (scm_is_null (dims
) || scm_is_pair (dims
),
575 dims
, SCM_ARG1
, FUNC_NAME
);
576 ra
= scm_shap2ra (dims
, FUNC_NAME
);
577 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
578 s
= SCM_ARRAY_DIMS (ra
);
579 k
= SCM_ARRAY_NDIM (ra
);
584 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
585 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
588 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
590 if (!SCM_UNBNDP (fill
))
591 scm_array_fill_x (ra
, fill
);
592 else if (scm_is_symbol (prot
))
593 scm_array_fill_x (ra
, scm_from_int (0));
595 scm_array_fill_x (ra
, prot
);
597 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
598 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
599 return SCM_ARRAY_V (ra
);
606 scm_ra_set_contp (SCM ra
)
608 size_t k
= SCM_ARRAY_NDIM (ra
);
611 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
614 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
616 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
619 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
620 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
623 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
627 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
628 (SCM oldra
, SCM mapfunc
, SCM dims
),
629 "@code{make-shared-array} can be used to create shared subarrays of other\n"
630 "arrays. The @var{mapper} is a function that translates coordinates in\n"
631 "the new array into coordinates in the old array. A @var{mapper} must be\n"
632 "linear, and its range must stay within the bounds of the old array, but\n"
633 "it can be otherwise arbitrary. A simple example:\n"
635 "(define fred (make-array #f 8 8))\n"
636 "(define freds-diagonal\n"
637 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
638 "(array-set! freds-diagonal 'foo 3)\n"
639 "(array-ref fred 3 3) @result{} foo\n"
640 "(define freds-center\n"
641 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
642 "(array-ref freds-center 0 0) @result{} foo\n"
644 #define FUNC_NAME s_scm_make_shared_array
650 long old_min
, new_min
, old_max
, new_max
;
653 SCM_VALIDATE_REST_ARGUMENT (dims
);
654 SCM_VALIDATE_ARRAY (1, oldra
);
655 SCM_VALIDATE_PROC (2, mapfunc
);
656 ra
= scm_shap2ra (dims
, FUNC_NAME
);
657 if (SCM_ARRAYP (oldra
))
659 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
660 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
661 s
= SCM_ARRAY_DIMS (oldra
);
662 k
= SCM_ARRAY_NDIM (oldra
);
666 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
668 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
673 SCM_ARRAY_V (ra
) = oldra
;
675 old_max
= scm_to_long (scm_uniform_vector_length (oldra
)) - 1;
678 s
= SCM_ARRAY_DIMS (ra
);
679 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
681 inds
= scm_cons (scm_from_long (s
[k
].lbnd
), inds
);
682 if (s
[k
].ubnd
< s
[k
].lbnd
)
684 if (1 == SCM_ARRAY_NDIM (ra
))
685 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
687 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
691 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
692 if (SCM_ARRAYP (oldra
))
693 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
696 if (!scm_is_integer (imap
))
698 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
699 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
700 imap
= SCM_CAR (imap
);
702 i
= scm_to_size_t (imap
);
704 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
706 k
= SCM_ARRAY_NDIM (ra
);
709 if (s
[k
].ubnd
> s
[k
].lbnd
)
711 SCM_SETCAR (indptr
, scm_sum (SCM_CAR (indptr
), scm_from_int (1)));
712 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
713 if (SCM_ARRAYP (oldra
))
715 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
718 if (!scm_is_integer (imap
))
720 if (scm_ilength (imap
) != 1 || !scm_is_integer (SCM_CAR (imap
)))
721 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
722 imap
= SCM_CAR (imap
);
724 s
[k
].inc
= scm_to_long (imap
) - i
;
728 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
730 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
733 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
734 indptr
= SCM_CDR (indptr
);
736 if (old_min
> new_min
|| old_max
< new_max
)
737 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
738 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
740 SCM v
= SCM_ARRAY_V (ra
);
741 unsigned long int length
= scm_to_ulong (scm_uniform_vector_length (v
));
742 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
744 if (s
->ubnd
< s
->lbnd
)
745 return scm_make_uve (0L, scm_array_prototype (ra
));
747 scm_ra_set_contp (ra
);
753 /* args are RA . DIMS */
754 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
756 "Return an array sharing contents with @var{array}, but with\n"
757 "dimensions arranged in a different order. There must be one\n"
758 "@var{dim} argument for each dimension of @var{array}.\n"
759 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
760 "and the rank of the array to be returned. Each integer in that\n"
761 "range must appear at least once in the argument list.\n"
763 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
764 "dimensions in the array to be returned, their positions in the\n"
765 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
766 "may have the same value, in which case the returned array will\n"
767 "have smaller rank than @var{array}.\n"
770 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
771 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
772 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
773 " #2((a 4) (b 5) (c 6))\n"
775 #define FUNC_NAME s_scm_transpose_array
778 SCM
const *ve
= &vargs
;
779 scm_t_array_dim
*s
, *r
;
782 SCM_VALIDATE_REST_ARGUMENT (args
);
783 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
784 switch (SCM_TYP7 (ra
))
787 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
797 #if SCM_SIZEOF_LONG_LONG != 0
800 if (scm_is_null (args
) || !scm_is_null (SCM_CDR (args
)))
801 SCM_WRONG_NUM_ARGS ();
802 SCM_VALIDATE_INT_COPY (SCM_ARG2
, SCM_CAR (args
), i
);
803 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
), i
== 0);
806 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
807 vargs
= scm_vector (args
);
808 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
809 SCM_WRONG_NUM_ARGS ();
810 ve
= SCM_VELTS (vargs
);
812 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
814 i
= scm_to_signed_integer (ve
[k
], 0, SCM_ARRAY_NDIM(ra
));
819 res
= scm_make_ra (ndim
);
820 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
821 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
824 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
825 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
827 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
829 i
= scm_to_int (ve
[k
]);
830 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
831 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
832 if (r
->ubnd
< r
->lbnd
)
841 if (r
->ubnd
> s
->ubnd
)
843 if (r
->lbnd
< s
->lbnd
)
845 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
852 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
853 scm_ra_set_contp (res
);
859 /* args are RA . AXES */
860 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
862 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
863 "the rank of @var{array}. @var{enclose-array} returns an array\n"
864 "resembling an array of shared arrays. The dimensions of each shared\n"
865 "array are the same as the @var{dim}th dimensions of the original array,\n"
866 "the dimensions of the outer array are the same as those of the original\n"
867 "array that did not match a @var{dim}.\n\n"
868 "An enclosed array is not a general Scheme array. Its elements may not\n"
869 "be set using @code{array-set!}. Two references to the same element of\n"
870 "an enclosed array will be @code{equal?} but will not in general be\n"
871 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
872 "enclosed array is unspecified.\n\n"
875 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
876 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
877 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
878 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
880 #define FUNC_NAME s_scm_enclose_array
882 SCM axv
, res
, ra_inr
;
884 scm_t_array_dim vdim
, *s
= &vdim
;
885 int ndim
, j
, k
, ninr
, noutr
;
887 SCM_VALIDATE_REST_ARGUMENT (axes
);
888 if (scm_is_null (axes
))
889 axes
= scm_cons ((SCM_ARRAYP (ra
) ? scm_from_size_t (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
890 ninr
= scm_ilength (axes
);
892 SCM_WRONG_NUM_ARGS ();
893 ra_inr
= scm_make_ra (ninr
);
894 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
898 badarg1
:SCM_WRONG_TYPE_ARG (1, ra
);
910 #if SCM_SIZEOF_LONG_LONG != 0
914 s
->ubnd
= scm_to_long (scm_uniform_vector_length (ra
)) - 1;
916 SCM_ARRAY_V (ra_inr
) = ra
;
917 SCM_ARRAY_BASE (ra_inr
) = 0;
921 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
922 s
= SCM_ARRAY_DIMS (ra
);
923 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
924 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
925 ndim
= SCM_ARRAY_NDIM (ra
);
930 SCM_WRONG_NUM_ARGS ();
931 axv
= scm_make_string (scm_from_int (ndim
), SCM_MAKE_CHAR (0));
932 res
= scm_make_ra (noutr
);
933 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
934 SCM_ARRAY_V (res
) = ra_inr
;
935 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
937 if (!scm_is_integer (SCM_CAR (axes
)))
938 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
939 j
= scm_to_int (SCM_CAR (axes
));
940 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
941 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
942 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
943 scm_c_string_set_x (axv
, j
, SCM_MAKE_CHAR (1));
945 c_axv
= scm_i_string_chars (axv
);
946 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
950 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
951 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
952 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
954 scm_remember_upto_here_1 (axv
);
955 scm_ra_set_contp (ra_inr
);
956 scm_ra_set_contp (res
);
963 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
965 "Return @code{#t} if its arguments would be acceptable to\n"
967 #define FUNC_NAME s_scm_array_in_bounds_p
975 SCM_VALIDATE_REST_ARGUMENT (args
);
976 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
980 ind
= SCM_CAR (args
);
981 args
= SCM_CDR (args
);
982 pos
= scm_to_long (ind
);
988 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
989 wna
: SCM_WRONG_NUM_ARGS ();
991 k
= SCM_ARRAY_NDIM (v
);
992 s
= SCM_ARRAY_DIMS (v
);
993 pos
= SCM_ARRAY_BASE (v
);
996 SCM_ASRTGO (scm_is_null (ind
), wna
);
1002 j
= scm_to_long (ind
);
1003 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1005 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1008 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1009 if (!(--k
&& SCM_NIMP (args
)))
1011 ind
= SCM_CAR (args
);
1012 args
= SCM_CDR (args
);
1014 if (!scm_is_integer (ind
))
1015 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
1017 SCM_ASRTGO (0 == k
, wna
);
1018 v
= SCM_ARRAY_V (v
);
1021 case scm_tc7_string
:
1022 case scm_tc7_byvect
:
1029 #if SCM_SIZEOF_LONG_LONG != 0
1030 case scm_tc7_llvect
:
1032 case scm_tc7_vector
:
1035 unsigned long length
= scm_to_ulong (scm_uniform_vector_length (v
));
1036 SCM_ASRTGO (scm_is_null (args
) && scm_is_integer (ind
), wna
);
1037 return scm_from_bool(pos
>= 0 && pos
< length
);
1044 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1047 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1049 "@deffnx {Scheme Procedure} array-ref v . args\n"
1050 "Return the element at the @code{(index1, index2)} element in\n"
1052 #define FUNC_NAME s_scm_uniform_vector_ref
1058 SCM_ASRTGO (scm_is_null (args
), badarg
);
1061 else if (SCM_ARRAYP (v
))
1063 pos
= scm_aind (v
, args
, FUNC_NAME
);
1064 v
= SCM_ARRAY_V (v
);
1068 unsigned long int length
;
1069 if (SCM_NIMP (args
))
1071 SCM_ASSERT (scm_is_pair (args
), args
, SCM_ARG2
, FUNC_NAME
);
1072 pos
= scm_to_long (SCM_CAR (args
));
1073 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1077 pos
= scm_to_long (args
);
1079 length
= scm_to_ulong (scm_uniform_vector_length (v
));
1080 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1085 if (scm_is_null (args
))
1088 SCM_WRONG_TYPE_ARG (1, v
);
1092 scm_out_of_range (FUNC_NAME
, scm_from_long (pos
));
1094 SCM_WRONG_NUM_ARGS ();
1097 int k
= SCM_ARRAY_NDIM (v
);
1098 SCM res
= scm_make_ra (k
);
1099 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1100 SCM_ARRAY_BASE (res
) = pos
;
1103 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1104 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1105 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1110 if (SCM_BITVEC_REF (v
, pos
))
1114 case scm_tc7_string
:
1115 return scm_c_string_ref (v
, pos
);
1116 case scm_tc7_byvect
:
1117 return scm_from_schar (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1119 return scm_from_ulong (((unsigned long *) SCM_VELTS (v
))[pos
]);
1121 return scm_from_long (((signed long *) SCM_VELTS (v
))[pos
]);
1124 return scm_from_short (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1125 #if SCM_SIZEOF_LONG_LONG != 0
1126 case scm_tc7_llvect
:
1127 return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1131 return scm_from_double (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1133 return scm_from_double (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1135 return scm_c_make_rectangular (((double *) SCM_CELL_WORD_1(v
))[2*pos
],
1136 ((double *) SCM_CELL_WORD_1(v
))[2*pos
+1]);
1137 case scm_tc7_vector
:
1139 return SCM_VELTS (v
)[pos
];
1144 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1145 tries to recycle conses. (Make *sure* you want them recycled.) */
1148 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1149 #define FUNC_NAME "scm_cvref"
1154 SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1156 if (SCM_BITVEC_REF(v
, pos
))
1160 case scm_tc7_string
:
1161 return scm_c_string_ref (v
, pos
);
1162 case scm_tc7_byvect
:
1163 return scm_from_char (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1165 return scm_from_ulong (((unsigned long *) SCM_VELTS (v
))[pos
]);
1167 return scm_from_long (((signed long *) SCM_VELTS (v
))[pos
]);
1169 return scm_from_short (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1170 #if SCM_SIZEOF_LONG_LONG != 0
1171 case scm_tc7_llvect
:
1172 return scm_from_long_long (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1175 if (SCM_REALP (last
) && !scm_is_eq (last
, scm_flo0
))
1177 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1180 return scm_from_double (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1182 if (SCM_REALP (last
) && !scm_is_eq (last
, scm_flo0
))
1184 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1187 return scm_from_double (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1189 if (SCM_COMPLEXP (last
))
1191 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1192 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1195 return scm_c_make_rectangular (((double *) SCM_CELL_WORD_1(v
))[2*pos
],
1196 ((double *) SCM_CELL_WORD_1(v
))[2*pos
+1]);
1197 case scm_tc7_vector
:
1199 return SCM_VELTS (v
)[pos
];
1201 { /* enclosed scm_array */
1202 int k
= SCM_ARRAY_NDIM (v
);
1203 SCM res
= scm_make_ra (k
);
1204 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1205 SCM_ARRAY_BASE (res
) = pos
;
1208 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1209 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1210 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1219 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1222 /* Note that args may be a list or an immediate object, depending which
1223 PROC is used (and it's called from C too). */
1224 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1225 (SCM v
, SCM obj
, SCM args
),
1226 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1227 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1228 "@var{new-value}. The value returned by array-set! is unspecified.")
1229 #define FUNC_NAME s_scm_array_set_x
1233 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1236 pos
= scm_aind (v
, args
, FUNC_NAME
);
1237 v
= SCM_ARRAY_V (v
);
1241 unsigned long int length
;
1242 if (scm_is_pair (args
))
1244 SCM_ASRTGO (scm_is_null (SCM_CDR (args
)), wna
);
1245 pos
= scm_to_long (SCM_CAR (args
));
1249 pos
= scm_to_long (args
);
1251 length
= scm_to_ulong (scm_uniform_vector_length (v
));
1252 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1254 switch (SCM_TYP7 (v
))
1257 SCM_WRONG_TYPE_ARG (1, v
);
1260 scm_out_of_range (FUNC_NAME
, scm_from_long (pos
));
1262 SCM_WRONG_NUM_ARGS ();
1263 case scm_tc7_smob
: /* enclosed */
1266 if (scm_is_false (obj
))
1267 SCM_BITVEC_CLR(v
, pos
);
1268 else if (scm_is_eq (obj
, SCM_BOOL_T
))
1269 SCM_BITVEC_SET(v
, pos
);
1271 badobj
:SCM_WRONG_TYPE_ARG (2, obj
);
1273 case scm_tc7_string
:
1274 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1275 scm_c_string_set_x (v
, pos
, obj
);
1277 case scm_tc7_byvect
:
1278 if (SCM_CHARP (obj
))
1279 obj
= scm_from_schar ((char) SCM_CHAR (obj
));
1280 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_schar (obj
);
1283 ((unsigned long *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_ulong (obj
);
1286 ((long *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_long (obj
);
1289 ((short *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_short (obj
);
1291 #if SCM_SIZEOF_LONG_LONG != 0
1292 case scm_tc7_llvect
:
1293 ((long long *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_long_long (obj
);
1297 ((float *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_double (obj
);
1300 ((double *) SCM_UVECTOR_BASE (v
))[pos
] = scm_to_double (obj
);
1303 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1304 if (SCM_REALP (obj
)) {
1305 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1306 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = 0.0;
1308 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1309 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1312 case scm_tc7_vector
:
1314 SCM_VECTOR_SET (v
, pos
, obj
);
1317 return SCM_UNSPECIFIED
;
1321 /* attempts to unroll an array into a one-dimensional array.
1322 returns the unrolled array or #f if it can't be done. */
1323 /* if strict is not SCM_UNDEFINED, return #f if returned array
1324 wouldn't have contiguous elements. */
1325 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1326 (SCM ra
, SCM strict
),
1327 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1328 "without changing their order (last subscript changing fastest), then\n"
1329 "@code{array-contents} returns that shared array, otherwise it returns\n"
1330 "@code{#f}. All arrays made by @var{make-array} and\n"
1331 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1332 "@var{make-shared-array} may not be.\n\n"
1333 "If the optional argument @var{strict} is provided, a shared array will\n"
1334 "be returned only if its elements are stored internally contiguous in\n"
1336 #define FUNC_NAME s_scm_array_contents
1341 switch SCM_TYP7 (ra
)
1345 case scm_tc7_vector
:
1347 case scm_tc7_string
:
1349 case scm_tc7_byvect
:
1356 #if SCM_SIZEOF_LONG_LONG != 0
1357 case scm_tc7_llvect
:
1362 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1363 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1365 for (k
= 0; k
< ndim
; k
++)
1366 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1367 if (!SCM_UNBNDP (strict
))
1369 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1371 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1373 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1374 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1381 SCM v
= SCM_ARRAY_V (ra
);
1382 unsigned long length
= scm_to_ulong (scm_uniform_vector_length (v
));
1383 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1387 sra
= scm_make_ra (1);
1388 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1389 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1390 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1391 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1392 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1401 scm_ra2contig (SCM ra
, int copy
)
1406 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1407 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1408 k
= SCM_ARRAY_NDIM (ra
);
1409 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1411 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1413 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1414 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1415 0 == len
% SCM_LONG_BIT
))
1418 ret
= scm_make_ra (k
);
1419 SCM_ARRAY_BASE (ret
) = 0;
1422 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1423 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1424 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1425 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1427 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_prototype (ra
));
1429 scm_array_copy_x (ra
, ret
);
1435 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1436 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1437 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1438 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1439 "binary objects from @var{port-or-fdes}.\n"
1440 "If an end of file is encountered,\n"
1441 "the objects up to that point are put into @var{ura}\n"
1442 "(starting at the beginning) and the remainder of the array is\n"
1444 "The optional arguments @var{start} and @var{end} allow\n"
1445 "a specified region of a vector (or linearized array) to be read,\n"
1446 "leaving the remainder of the vector unchanged.\n\n"
1447 "@code{uniform-array-read!} returns the number of objects read.\n"
1448 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1449 "returned by @code{(current-input-port)}.")
1450 #define FUNC_NAME s_scm_uniform_array_read_x
1452 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1459 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1460 if (SCM_UNBNDP (port_or_fd
))
1461 port_or_fd
= scm_cur_inp
;
1463 SCM_ASSERT (scm_is_integer (port_or_fd
)
1464 || (SCM_OPINPORTP (port_or_fd
)),
1465 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1466 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1468 : scm_to_long (scm_uniform_vector_length (v
)));
1474 badarg1
:SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1476 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1477 cra
= scm_ra2contig (ra
, 0);
1478 cstart
+= SCM_ARRAY_BASE (cra
);
1479 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1480 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1481 v
= SCM_ARRAY_V (cra
);
1483 case scm_tc7_string
:
1484 base
= NULL
; /* writing to strings is special, see below. */
1488 base
= (char *) SCM_BITVECTOR_BASE (v
);
1489 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1490 cstart
/= SCM_LONG_BIT
;
1493 case scm_tc7_byvect
:
1494 base
= (char *) SCM_UVECTOR_BASE (v
);
1499 base
= (char *) SCM_UVECTOR_BASE (v
);
1503 base
= (char *) SCM_UVECTOR_BASE (v
);
1504 sz
= sizeof (short);
1506 #if SCM_SIZEOF_LONG_LONG != 0
1507 case scm_tc7_llvect
:
1508 base
= (char *) SCM_UVECTOR_BASE (v
);
1509 sz
= sizeof (long long);
1513 base
= (char *) SCM_UVECTOR_BASE (v
);
1514 sz
= sizeof (float);
1517 base
= (char *) SCM_UVECTOR_BASE (v
);
1518 sz
= sizeof (double);
1521 base
= (char *) SCM_UVECTOR_BASE (v
);
1522 sz
= 2 * sizeof (double);
1527 if (!SCM_UNBNDP (start
))
1530 SCM_NUM2LONG (3, start
);
1532 if (offset
< 0 || offset
>= cend
)
1533 scm_out_of_range (FUNC_NAME
, start
);
1535 if (!SCM_UNBNDP (end
))
1538 SCM_NUM2LONG (4, end
);
1540 if (tend
<= offset
|| tend
> cend
)
1541 scm_out_of_range (FUNC_NAME
, end
);
1546 if (SCM_NIMP (port_or_fd
))
1548 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1549 int remaining
= (cend
- offset
) * sz
;
1550 size_t off
= (cstart
+ offset
) * sz
;
1552 if (pt
->rw_active
== SCM_PORT_WRITE
)
1553 scm_flush (port_or_fd
);
1555 ans
= cend
- offset
;
1556 while (remaining
> 0)
1558 if (pt
->read_pos
< pt
->read_end
)
1560 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1566 char *b
= scm_i_string_writable_chars (v
);
1567 memcpy (b
+ off
, pt
->read_pos
, to_copy
);
1568 scm_i_string_stop_writing ();
1571 memcpy (base
+ off
, pt
->read_pos
, to_copy
);
1572 pt
->read_pos
+= to_copy
;
1573 remaining
-= to_copy
;
1578 if (scm_fill_input (port_or_fd
) == EOF
)
1580 if (remaining
% sz
!= 0)
1582 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1584 ans
-= remaining
/ sz
;
1591 pt
->rw_active
= SCM_PORT_READ
;
1593 else /* file descriptor. */
1598 char *b
= scm_i_string_writable_chars (v
);
1599 SCM_SYSCALL (ans
= read (scm_to_int (port_or_fd
),
1600 b
+ (cstart
+ offset
) * sz
,
1601 (sz
* (cend
- offset
))));
1602 scm_i_string_stop_writing ();
1605 SCM_SYSCALL (ans
= read (scm_to_int (port_or_fd
),
1606 base
+ (cstart
+ offset
) * sz
,
1607 (sz
* (cend
- offset
))));
1611 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1612 ans
*= SCM_LONG_BIT
;
1614 if (!scm_is_eq (v
, ra
) && !scm_is_eq (cra
, ra
))
1615 scm_array_copy_x (cra
, ra
);
1617 return scm_from_long (ans
);
1621 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1622 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1623 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1624 "Writes all elements of @var{ura} as binary objects to\n"
1625 "@var{port-or-fdes}.\n\n"
1626 "The optional arguments @var{start}\n"
1627 "and @var{end} allow\n"
1628 "a specified region of a vector (or linearized array) to be written.\n\n"
1629 "The number of objects actually written is returned.\n"
1630 "@var{port-or-fdes} may be\n"
1631 "omitted, in which case it defaults to the value returned by\n"
1632 "@code{(current-output-port)}.")
1633 #define FUNC_NAME s_scm_uniform_array_write
1641 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1643 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1644 if (SCM_UNBNDP (port_or_fd
))
1645 port_or_fd
= scm_cur_outp
;
1647 SCM_ASSERT (scm_is_integer (port_or_fd
)
1648 || (SCM_OPOUTPORTP (port_or_fd
)),
1649 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1650 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1652 : scm_to_long (scm_uniform_vector_length (v
)));
1658 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1660 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1661 v
= scm_ra2contig (v
, 1);
1662 cstart
= SCM_ARRAY_BASE (v
);
1663 vlen
= (SCM_ARRAY_DIMS (v
)->inc
1664 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1));
1665 v
= SCM_ARRAY_V (v
);
1667 case scm_tc7_string
:
1668 base
= scm_i_string_chars (v
);
1672 base
= (char *) SCM_BITVECTOR_BASE (v
);
1673 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1674 cstart
/= SCM_LONG_BIT
;
1677 case scm_tc7_byvect
:
1678 base
= (char *) SCM_UVECTOR_BASE (v
);
1683 base
= (char *) SCM_UVECTOR_BASE (v
);
1687 base
= (char *) SCM_UVECTOR_BASE (v
);
1688 sz
= sizeof (short);
1690 #if SCM_SIZEOF_LONG_LONG != 0
1691 case scm_tc7_llvect
:
1692 base
= (char *) SCM_UVECTOR_BASE (v
);
1693 sz
= sizeof (long long);
1697 base
= (char *) SCM_UVECTOR_BASE (v
);
1698 sz
= sizeof (float);
1701 base
= (char *) SCM_UVECTOR_BASE (v
);
1702 sz
= sizeof (double);
1705 base
= (char *) SCM_UVECTOR_BASE (v
);
1706 sz
= 2 * sizeof (double);
1711 if (!SCM_UNBNDP (start
))
1714 SCM_NUM2LONG (3, start
);
1716 if (offset
< 0 || offset
>= cend
)
1717 scm_out_of_range (FUNC_NAME
, start
);
1719 if (!SCM_UNBNDP (end
))
1722 SCM_NUM2LONG (4, end
);
1724 if (tend
<= offset
|| tend
> cend
)
1725 scm_out_of_range (FUNC_NAME
, end
);
1730 if (SCM_NIMP (port_or_fd
))
1732 const char *source
= base
+ (cstart
+ offset
) * sz
;
1734 ans
= cend
- offset
;
1735 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1737 else /* file descriptor. */
1739 SCM_SYSCALL (ans
= write (scm_to_int (port_or_fd
),
1740 base
+ (cstart
+ offset
) * sz
,
1741 (sz
* (cend
- offset
))));
1745 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1746 ans
*= SCM_LONG_BIT
;
1748 return scm_from_long (ans
);
1753 static char cnt_tab
[16] =
1754 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1756 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1757 (SCM b
, SCM bitvector
),
1758 "Return the number of occurrences of the boolean @var{b} in\n"
1760 #define FUNC_NAME s_scm_bit_count
1762 SCM_VALIDATE_BOOL (1, b
);
1763 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1764 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1767 unsigned long int count
= 0;
1768 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1769 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1770 if (scm_is_false (b
)) {
1773 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1776 count
+= cnt_tab
[w
& 0x0f];
1780 return scm_from_ulong (count
);
1783 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1784 if (scm_is_false (b
)) {
1794 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1795 (SCM item
, SCM v
, SCM k
),
1796 "Return the index of the first occurrance of @var{item} in bit\n"
1797 "vector @var{v}, starting from @var{k}. If there is no\n"
1798 "@var{item} entry between @var{k} and the end of\n"
1799 "@var{bitvector}, then return @code{#f}. For example,\n"
1802 "(bit-position #t #*000101 0) @result{} 3\n"
1803 "(bit-position #f #*0001111 3) @result{} #f\n"
1805 #define FUNC_NAME s_scm_bit_position
1807 long i
, lenw
, xbits
, pos
;
1808 register unsigned long w
;
1810 SCM_VALIDATE_BOOL (1, item
);
1811 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1812 pos
= scm_to_long (k
);
1813 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1815 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1818 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1819 i
= pos
/ SCM_LONG_BIT
;
1820 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1821 if (scm_is_false (item
))
1823 xbits
= (pos
% SCM_LONG_BIT
);
1825 w
= ((w
>> xbits
) << xbits
);
1826 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1829 if (w
&& (i
== lenw
))
1830 w
= ((w
<< xbits
) >> xbits
);
1836 return scm_from_long (pos
);
1841 return scm_from_long (pos
+ 1);
1844 return scm_from_long (pos
+ 2);
1846 return scm_from_long (pos
+ 3);
1853 pos
+= SCM_LONG_BIT
;
1854 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1855 if (scm_is_false (item
))
1863 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1864 (SCM v
, SCM kv
, SCM obj
),
1865 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1866 "selecting the entries to change. The return value is\n"
1869 "If @var{kv} is a bit vector, then those entries where it has\n"
1870 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1871 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1872 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1873 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1876 "(define bv #*01000010)\n"
1877 "(bit-set*! bv #*10010001 #t)\n"
1879 "@result{} #*11010011\n"
1882 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1883 "they're indexes into @var{v} which are set to @var{obj}.\n"
1886 "(define bv #*01000010)\n"
1887 "(bit-set*! bv #u(5 2 7) #t)\n"
1889 "@result{} #*01100111\n"
1891 #define FUNC_NAME s_scm_bit_set_star_x
1893 register long i
, k
, vlen
;
1894 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1895 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1896 switch SCM_TYP7 (kv
)
1899 badarg2
:SCM_WRONG_TYPE_ARG (2, kv
);
1901 vlen
= SCM_BITVECTOR_LENGTH (v
);
1902 if (scm_is_false (obj
))
1903 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1905 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1907 scm_out_of_range (FUNC_NAME
, scm_from_long (k
));
1908 SCM_BITVEC_CLR(v
, k
);
1910 else if (scm_is_eq (obj
, SCM_BOOL_T
))
1911 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1913 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1915 scm_out_of_range (FUNC_NAME
, scm_from_long (k
));
1916 SCM_BITVEC_SET(v
, k
);
1919 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1922 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1923 if (scm_is_false (obj
))
1924 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1925 SCM_BITVECTOR_BASE (v
) [k
] &= ~SCM_BITVECTOR_BASE (kv
) [k
];
1926 else if (scm_is_eq (obj
, SCM_BOOL_T
))
1927 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1928 SCM_BITVECTOR_BASE (v
) [k
] |= SCM_BITVECTOR_BASE (kv
) [k
];
1933 return SCM_UNSPECIFIED
;
1938 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1939 (SCM v
, SCM kv
, SCM obj
),
1940 "Return a count of how many entries in bit vector @var{v} are\n"
1941 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1944 "If @var{kv} is a bit vector, then those entries where it has\n"
1945 "@code{#t} are the ones in @var{v} which are considered.\n"
1946 "@var{kv} and @var{v} must be the same length.\n"
1948 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1949 "it's the indexes in @var{v} to consider.\n"
1954 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1955 "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n"
1957 #define FUNC_NAME s_scm_bit_count_star
1959 register long i
, vlen
, count
= 0;
1960 register unsigned long k
;
1963 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1964 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1965 switch SCM_TYP7 (kv
)
1969 SCM_WRONG_TYPE_ARG (2, kv
);
1971 vlen
= SCM_BITVECTOR_LENGTH (v
);
1972 if (scm_is_false (obj
))
1973 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1975 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1977 scm_out_of_range (FUNC_NAME
, scm_from_long (k
));
1978 if (!SCM_BITVEC_REF(v
, k
))
1981 else if (scm_is_eq (obj
, SCM_BOOL_T
))
1982 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1984 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1986 scm_out_of_range (FUNC_NAME
, scm_from_long (k
));
1987 if (SCM_BITVEC_REF (v
, k
))
1991 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1994 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1995 if (0 == SCM_BITVECTOR_LENGTH (v
))
1997 SCM_ASRTGO (scm_is_bool (obj
), badarg3
);
1998 fObj
= scm_is_eq (obj
, SCM_BOOL_T
);
1999 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
2000 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
2001 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
2005 count
+= cnt_tab
[k
& 0x0f];
2007 return scm_from_long (count
);
2009 /* urg. repetitive (see above.) */
2010 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
2013 return scm_from_long (count
);
2018 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2020 "Modify the bit vector @var{v} by replacing each element with\n"
2022 #define FUNC_NAME s_scm_bit_invert_x
2026 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
2028 k
= SCM_BITVECTOR_LENGTH (v
);
2029 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
2030 SCM_BITVECTOR_BASE (v
) [k
] = ~SCM_BITVECTOR_BASE (v
) [k
];
2032 return SCM_UNSPECIFIED
;
2038 scm_istr2bve (SCM str
)
2040 size_t len
= scm_i_string_length (str
);
2041 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
2042 long *data
= (long *) SCM_VELTS (v
);
2043 register unsigned long mask
;
2046 const char *c_str
= scm_i_string_chars (str
);
2048 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2051 j
= len
- k
* SCM_LONG_BIT
;
2052 if (j
> SCM_LONG_BIT
)
2054 for (mask
= 1L; j
--; mask
<<= 1)
2072 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2074 register SCM res
= SCM_EOL
;
2075 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2077 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2079 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2080 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2085 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2093 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), scm_from_size_t (i
)), res
);
2100 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2102 "Return a list consisting of all the elements, in order, of\n"
2104 #define FUNC_NAME s_scm_array_to_list
2108 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2112 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
2114 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2115 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2116 case scm_tc7_vector
:
2118 return scm_vector_to_list (v
);
2119 case scm_tc7_string
:
2120 return scm_string_to_list (v
);
2123 long *data
= (long *) SCM_VELTS (v
);
2124 register unsigned long mask
;
2125 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2126 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2127 res
= scm_cons (scm_from_bool(((long *) data
)[k
] & mask
), res
);
2128 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2129 res
= scm_cons (scm_from_bool(((long *) data
)[k
] & mask
), res
);
2132 case scm_tc7_byvect
:
2134 signed char *data
= (signed char *) SCM_VELTS (v
);
2135 unsigned long k
= SCM_UVECTOR_LENGTH (v
);
2137 res
= scm_cons (scm_from_schar (data
[--k
]), res
);
2142 unsigned long *data
= (unsigned long *)SCM_VELTS(v
);
2143 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2144 res
= scm_cons(scm_from_ulong (data
[k
]), res
);
2149 long *data
= (long *)SCM_VELTS(v
);
2150 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2151 res
= scm_cons(scm_from_long (data
[k
]), res
);
2156 short *data
= (short *)SCM_VELTS(v
);
2157 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2158 res
= scm_cons (scm_from_short (data
[k
]), res
);
2161 #if SCM_SIZEOF_LONG_LONG != 0
2162 case scm_tc7_llvect
:
2164 long long *data
= (long long *)SCM_VELTS(v
);
2165 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2166 res
= scm_cons(scm_from_long_long (data
[k
]), res
);
2172 float *data
= (float *) SCM_VELTS (v
);
2173 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2174 res
= scm_cons (scm_from_double (data
[k
]), res
);
2179 double *data
= (double *) SCM_VELTS (v
);
2180 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2181 res
= scm_cons (scm_from_double (data
[k
]), res
);
2186 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2187 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2188 res
= scm_cons (scm_c_make_rectangular (data
[k
][0], data
[k
][1]),
2197 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2199 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2200 (SCM ndim
, SCM prot
, SCM lst
),
2201 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2202 "Return a uniform array of the type indicated by prototype\n"
2203 "@var{prot} with elements the same as those of @var{lst}.\n"
2204 "Elements must be of the appropriate type, no coercions are\n"
2206 #define FUNC_NAME s_scm_list_to_uniform_array
2213 k
= scm_to_ulong (ndim
);
2216 n
= scm_ilength (row
);
2217 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2218 shp
= scm_cons (scm_from_long (n
), shp
);
2220 row
= SCM_CAR (row
);
2222 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2224 if (scm_is_null (shp
))
2226 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2227 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2230 if (!SCM_ARRAYP (ra
))
2232 unsigned long length
= scm_to_ulong (scm_uniform_vector_length (ra
));
2233 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2234 scm_array_set_x (ra
, SCM_CAR (lst
), scm_from_ulong (k
));
2237 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2240 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2246 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2248 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2249 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2252 return (scm_is_null (lst
));
2253 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2257 if (!scm_is_pair (lst
))
2259 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2261 lst
= SCM_CDR (lst
);
2263 if (!scm_is_null (lst
))
2270 if (!scm_is_pair (lst
))
2272 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), scm_from_ulong (base
));
2274 lst
= SCM_CDR (lst
);
2276 if (!scm_is_null (lst
))
2284 rapr1 (SCM ra
, unsigned long j
, unsigned long k
, SCM port
, scm_print_state
*pstate
)
2287 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2289 : scm_to_long (scm_uniform_vector_length (ra
)));
2292 switch SCM_TYP7 (ra
)
2297 SCM_ARRAY_BASE (ra
) = j
;
2299 scm_iprin1 (ra
, port
, pstate
);
2300 for (j
+= inc
; n
-- > 0; j
+= inc
)
2302 scm_putc (' ', port
);
2303 SCM_ARRAY_BASE (ra
) = j
;
2304 scm_iprin1 (ra
, port
, pstate
);
2308 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2311 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2312 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2314 scm_putc ('(', port
);
2315 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2316 scm_puts (") ", port
);
2319 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2320 { /* could be zero size. */
2321 scm_putc ('(', port
);
2322 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2323 scm_putc (')', port
);
2327 if (SCM_ARRAY_NDIM (ra
) > 0)
2328 { /* Could be zero-dimensional */
2329 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2330 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2334 ra
= SCM_ARRAY_V (ra
);
2337 /* scm_tc7_bvect and scm_tc7_llvect only? */
2339 scm_iprin1 (scm_uniform_vector_ref (ra
, scm_from_ulong (j
)), port
, pstate
);
2340 for (j
+= inc
; n
-- > 0; j
+= inc
)
2342 scm_putc (' ', port
);
2343 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2346 case scm_tc7_string
:
2349 src
= scm_i_string_chars (ra
);
2351 scm_iprin1 (SCM_MAKE_CHAR (src
[j
]), port
, pstate
);
2352 if (SCM_WRITINGP (pstate
))
2353 for (j
+= inc
; n
-- > 0; j
+= inc
)
2355 scm_putc (' ', port
);
2356 scm_iprin1 (SCM_MAKE_CHAR (src
[j
]), port
, pstate
);
2359 for (j
+= inc
; n
-- > 0; j
+= inc
)
2360 scm_putc (src
[j
], port
);
2361 scm_remember_upto_here_1 (ra
);
2364 case scm_tc7_byvect
:
2366 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2367 for (j
+= inc
; n
-- > 0; j
+= inc
)
2369 scm_putc (' ', port
);
2370 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2380 /* intprint can't handle >= 2^31. */
2381 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2382 scm_puts (str
, port
);
2384 for (j
+= inc
; n
-- > 0; j
+= inc
)
2386 scm_putc (' ', port
);
2387 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2388 scm_puts (str
, port
);
2393 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2394 for (j
+= inc
; n
-- > 0; j
+= inc
)
2396 scm_putc (' ', port
);
2397 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2403 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2404 for (j
+= inc
; n
-- > 0; j
+= inc
)
2406 scm_putc (' ', port
);
2407 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2414 SCM z
= scm_from_double (1.0);
2415 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2416 scm_print_real (z
, port
, pstate
);
2417 for (j
+= inc
; n
-- > 0; j
+= inc
)
2419 scm_putc (' ', port
);
2420 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2421 scm_print_real (z
, port
, pstate
);
2428 SCM z
= scm_from_double (1.0 / 3.0);
2429 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2430 scm_print_real (z
, port
, pstate
);
2431 for (j
+= inc
; n
-- > 0; j
+= inc
)
2433 scm_putc (' ', port
);
2434 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2435 scm_print_real (z
, port
, pstate
);
2442 SCM cz
= scm_c_make_rectangular (0.0, 1.0);
2443 SCM z
= scm_from_double (1.0/3.0);
2444 SCM_REAL_VALUE (z
) =
2445 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2446 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2447 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2449 for (j
+= inc
; n
-- > 0; j
+= inc
)
2451 scm_putc (' ', port
);
2453 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2454 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2455 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2466 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2469 unsigned long base
= 0;
2470 scm_putc ('#', port
);
2476 long ndim
= SCM_ARRAY_NDIM (v
);
2477 base
= SCM_ARRAY_BASE (v
);
2478 v
= SCM_ARRAY_V (v
);
2482 scm_puts ("<enclosed-array ", port
);
2483 rapr1 (exp
, base
, 0, port
, pstate
);
2484 scm_putc ('>', port
);
2489 scm_intprint (ndim
, 10, port
);
2494 if (scm_is_eq (exp
, v
))
2495 { /* a uve, not an scm_array */
2496 register long i
, j
, w
;
2497 scm_putc ('*', port
);
2498 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2500 scm_t_bits w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2501 for (j
= SCM_LONG_BIT
; j
; j
--)
2503 scm_putc (w
& 1 ? '1' : '0', port
);
2507 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2510 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2513 scm_putc (w
& 1 ? '1' : '0', port
);
2520 scm_putc ('b', port
);
2522 case scm_tc7_string
:
2523 scm_putc ('a', port
);
2525 case scm_tc7_byvect
:
2526 scm_putc ('y', port
);
2529 scm_putc ('u', port
);
2532 scm_putc ('e', port
);
2535 scm_putc ('h', port
);
2537 #if SCM_SIZEOF_LONG_LONG != 0
2538 case scm_tc7_llvect
:
2539 scm_putc ('l', port
);
2543 scm_putc ('s', port
);
2546 scm_putc ('i', port
);
2549 scm_putc ('c', port
);
2552 scm_putc ('(', port
);
2553 rapr1 (exp
, base
, 0, port
, pstate
);
2554 scm_putc (')', port
);
2558 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2560 "Return an object that would produce an array of the same type\n"
2561 "as @var{array}, if used as the @var{prototype} for\n"
2562 "@code{make-uniform-array}.")
2563 #define FUNC_NAME s_scm_array_prototype
2566 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2568 switch SCM_TYP7 (ra
)
2571 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
2573 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2575 return SCM_UNSPECIFIED
;
2576 ra
= SCM_ARRAY_V (ra
);
2578 case scm_tc7_vector
:
2583 case scm_tc7_string
:
2584 return SCM_MAKE_CHAR ('a');
2585 case scm_tc7_byvect
:
2586 return SCM_MAKE_CHAR ('\0');
2588 return scm_from_int (1);
2590 return scm_from_int (-1);
2592 return scm_from_locale_symbol ("s");
2593 #if SCM_SIZEOF_LONG_LONG != 0
2594 case scm_tc7_llvect
:
2595 return scm_from_locale_symbol ("l");
2598 return scm_from_double (1.0);
2600 return exactly_one_third
;
2602 return scm_c_make_rectangular (0.0, 1.0);
2609 array_mark (SCM ptr
)
2611 return SCM_ARRAY_V (ptr
);
2616 array_free (SCM ptr
)
2618 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2619 (sizeof (scm_t_array
)
2620 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2628 scm_tc16_array
= scm_make_smob_type ("array", 0);
2629 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2630 scm_set_smob_free (scm_tc16_array
, array_free
);
2631 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2632 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2633 exactly_one_third
= scm_permanent_object (scm_divide (scm_from_int (1),
2635 scm_add_feature ("array");
2636 #include "libguile/unif.x"