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/strop.h"
42 #include "libguile/feature.h"
43 #include "libguile/root.h"
44 #include "libguile/strings.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_long2num (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_EQ_P (prot
, SCM_BOOL_T
))
161 scm_long2num (k
), 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_allocate_string (sizeof (char) * k
);
173 else if (SCM_INUMP (prot
))
174 return make_uve (SCM_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_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
186 s
= SCM_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_MAKINUM (SCM_VECTOR_LENGTH (v
));
223 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
225 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
233 #if SCM_SIZEOF_LONG_LONG != 0
236 return SCM_MAKINUM (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_BOOL(nprot
);
271 switch (SCM_TYP7 (v
))
274 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
277 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
280 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
283 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
286 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
289 protp
= SCM_SYMBOLP (prot
)
290 && (1 == SCM_SYMBOL_LENGTH (prot
))
291 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
293 #if SCM_SIZEOF_LONG_LONG != 0
295 protp
= SCM_SYMBOLP (prot
)
296 && (1 == SCM_SYMBOL_LENGTH (prot
))
297 && ('l' == SCM_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_NULLP(prot
);
319 return SCM_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_MAKINUM (1L);
353 return SCM_MAKINUM (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_MAKINUM (s
[k
].lbnd
),
401 SCM_MAKINUM (s
[k
].ubnd
),
403 : SCM_MAKINUM (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_MAKINUM (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_MAKINUM (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_INUMP (args
))
466 scm_error_num_args_subr (what
);
467 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
469 while (k
&& SCM_CONSP (args
))
471 ind
= SCM_CAR (args
);
472 args
= SCM_CDR (args
);
473 if (!SCM_INUMP (ind
))
474 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
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_NULLP (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_NULLP (args
); s
++, args
= SCM_CDR (args
))
522 spec
= SCM_CAR (args
);
523 if (SCM_INUMP (spec
))
525 if (SCM_INUM (spec
) < 0)
526 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
528 s
->ubnd
= SCM_INUM (spec
) - 1;
533 if (!SCM_CONSP (spec
) || !SCM_INUMP (SCM_CAR (spec
)))
534 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
535 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
538 || !SCM_INUMP (SCM_CAR (sp
))
539 || !SCM_NULLP (SCM_CDR (sp
)))
540 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
541 s
->ubnd
= SCM_INUM (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_INUMP (dims
))
564 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
565 if (!SCM_UNBNDP (fill
))
566 scm_array_fill_x (answer
, fill
);
567 else if (SCM_SYMBOLP (prot
))
568 scm_array_fill_x (answer
, SCM_MAKINUM (0));
570 scm_array_fill_x (answer
, prot
);
574 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (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_SYMBOLP (prot
))
593 scm_array_fill_x (ra
, SCM_MAKINUM (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_INUM (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_MAKINUM (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_NINUMP (imap
))
699 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
700 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
701 imap
= SCM_CAR (imap
);
705 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
707 k
= SCM_ARRAY_NDIM (ra
);
710 if (s
[k
].ubnd
> s
[k
].lbnd
)
712 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
713 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
714 if (SCM_ARRAYP (oldra
))
716 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
719 if (SCM_NINUMP (imap
))
721 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
722 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
723 imap
= SCM_CAR (imap
);
725 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
729 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
731 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
734 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
735 indptr
= SCM_CDR (indptr
);
737 if (old_min
> new_min
|| old_max
< new_max
)
738 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
739 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
741 SCM v
= SCM_ARRAY_V (ra
);
742 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
743 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
745 if (s
->ubnd
< s
->lbnd
)
746 return scm_make_uve (0L, scm_array_prototype (ra
));
748 scm_ra_set_contp (ra
);
754 /* args are RA . DIMS */
755 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
757 "Return an array sharing contents with @var{array}, but with\n"
758 "dimensions arranged in a different order. There must be one\n"
759 "@var{dim} argument for each dimension of @var{array}.\n"
760 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
761 "and the rank of the array to be returned. Each integer in that\n"
762 "range must appear at least once in the argument list.\n"
764 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
765 "dimensions in the array to be returned, their positions in the\n"
766 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
767 "may have the same value, in which case the returned array will\n"
768 "have smaller rank than @var{array}.\n"
771 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
772 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
773 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
774 " #2((a 4) (b 5) (c 6))\n"
776 #define FUNC_NAME s_scm_transpose_array
779 SCM
const *ve
= &vargs
;
780 scm_t_array_dim
*s
, *r
;
783 SCM_VALIDATE_REST_ARGUMENT (args
);
784 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
785 switch (SCM_TYP7 (ra
))
788 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
798 #if SCM_SIZEOF_LONG_LONG != 0
801 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
802 SCM_WRONG_NUM_ARGS ();
803 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CAR (args
));
804 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
805 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
808 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
809 vargs
= scm_vector (args
);
810 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
811 SCM_WRONG_NUM_ARGS ();
812 ve
= SCM_VELTS (vargs
);
814 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
816 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
818 i
= SCM_INUM (ve
[k
]);
819 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
820 scm_out_of_range (FUNC_NAME
, ve
[k
]);
825 res
= scm_make_ra (ndim
);
826 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
827 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
830 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
831 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
833 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
835 i
= SCM_INUM (ve
[k
]);
836 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
837 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
838 if (r
->ubnd
< r
->lbnd
)
847 if (r
->ubnd
> s
->ubnd
)
849 if (r
->lbnd
< s
->lbnd
)
851 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
858 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
859 scm_ra_set_contp (res
);
865 /* args are RA . AXES */
866 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
868 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
869 "the rank of @var{array}. @var{enclose-array} returns an array\n"
870 "resembling an array of shared arrays. The dimensions of each shared\n"
871 "array are the same as the @var{dim}th dimensions of the original array,\n"
872 "the dimensions of the outer array are the same as those of the original\n"
873 "array that did not match a @var{dim}.\n\n"
874 "An enclosed array is not a general Scheme array. Its elements may not\n"
875 "be set using @code{array-set!}. Two references to the same element of\n"
876 "an enclosed array will be @code{equal?} but will not in general be\n"
877 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
878 "enclosed array is unspecified.\n\n"
881 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
882 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
883 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
884 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
886 #define FUNC_NAME s_scm_enclose_array
888 SCM axv
, res
, ra_inr
;
889 scm_t_array_dim vdim
, *s
= &vdim
;
890 int ndim
, j
, k
, ninr
, noutr
;
892 SCM_VALIDATE_REST_ARGUMENT (axes
);
893 if (SCM_NULLP (axes
))
894 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
895 ninr
= scm_ilength (axes
);
897 SCM_WRONG_NUM_ARGS ();
898 ra_inr
= scm_make_ra (ninr
);
899 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
903 badarg1
:SCM_WRONG_TYPE_ARG (1, ra
);
915 #if SCM_SIZEOF_LONG_LONG != 0
919 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
921 SCM_ARRAY_V (ra_inr
) = ra
;
922 SCM_ARRAY_BASE (ra_inr
) = 0;
926 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
927 s
= SCM_ARRAY_DIMS (ra
);
928 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
929 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
930 ndim
= SCM_ARRAY_NDIM (ra
);
935 SCM_WRONG_NUM_ARGS ();
936 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
937 res
= scm_make_ra (noutr
);
938 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
939 SCM_ARRAY_V (res
) = ra_inr
;
940 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
942 if (!SCM_INUMP (SCM_CAR (axes
)))
943 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
944 j
= SCM_INUM (SCM_CAR (axes
));
945 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
946 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
947 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
948 SCM_STRING_CHARS (axv
)[j
] = 1;
950 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
952 while (SCM_STRING_CHARS (axv
)[j
])
954 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
955 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
956 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
958 scm_ra_set_contp (ra_inr
);
959 scm_ra_set_contp (res
);
966 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
968 "Return @code{#t} if its arguments would be acceptable to\n"
970 #define FUNC_NAME s_scm_array_in_bounds_p
978 SCM_VALIDATE_REST_ARGUMENT (args
);
979 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
983 ind
= SCM_CAR (args
);
984 args
= SCM_CDR (args
);
985 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
986 pos
= SCM_INUM (ind
);
992 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
993 wna
: SCM_WRONG_NUM_ARGS ();
995 k
= SCM_ARRAY_NDIM (v
);
996 s
= SCM_ARRAY_DIMS (v
);
997 pos
= SCM_ARRAY_BASE (v
);
1000 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1007 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1009 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1012 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1013 if (!(--k
&& SCM_NIMP (args
)))
1015 ind
= SCM_CAR (args
);
1016 args
= SCM_CDR (args
);
1018 if (!SCM_INUMP (ind
))
1019 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
1021 SCM_ASRTGO (0 == k
, wna
);
1022 v
= SCM_ARRAY_V (v
);
1025 case scm_tc7_string
:
1026 case scm_tc7_byvect
:
1033 #if SCM_SIZEOF_LONG_LONG != 0
1034 case scm_tc7_llvect
:
1036 case scm_tc7_vector
:
1039 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1040 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1041 return SCM_BOOL(pos
>= 0 && pos
< length
);
1048 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1051 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1053 "@deffnx {Scheme Procedure} array-ref v . args\n"
1054 "Return the element at the @code{(index1, index2)} element in\n"
1056 #define FUNC_NAME s_scm_uniform_vector_ref
1062 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1065 else if (SCM_ARRAYP (v
))
1067 pos
= scm_aind (v
, args
, FUNC_NAME
);
1068 v
= SCM_ARRAY_V (v
);
1072 unsigned long int length
;
1073 if (SCM_NIMP (args
))
1075 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1076 pos
= SCM_INUM (SCM_CAR (args
));
1077 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1081 SCM_VALIDATE_INUM (2, args
);
1082 pos
= SCM_INUM (args
);
1084 length
= SCM_INUM (scm_uniform_vector_length (v
));
1085 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1090 if (SCM_NULLP (args
))
1093 SCM_WRONG_TYPE_ARG (1, v
);
1097 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1099 SCM_WRONG_NUM_ARGS ();
1102 int k
= SCM_ARRAY_NDIM (v
);
1103 SCM res
= scm_make_ra (k
);
1104 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1105 SCM_ARRAY_BASE (res
) = pos
;
1108 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1109 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1110 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1115 if (SCM_BITVEC_REF (v
, pos
))
1119 case scm_tc7_string
:
1120 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1121 case scm_tc7_byvect
:
1122 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1124 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1126 return scm_long2num (((signed long *) SCM_VELTS (v
))[pos
]);
1129 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1130 #if SCM_SIZEOF_LONG_LONG != 0
1131 case scm_tc7_llvect
:
1132 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1136 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1138 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1140 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1141 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1142 case scm_tc7_vector
:
1144 return SCM_VELTS (v
)[pos
];
1149 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1150 tries to recycle conses. (Make *sure* you want them recycled.) */
1153 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1154 #define FUNC_NAME "scm_cvref"
1159 SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1161 if (SCM_BITVEC_REF(v
, pos
))
1165 case scm_tc7_string
:
1166 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1167 case scm_tc7_byvect
:
1168 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1170 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1172 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1174 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1175 #if SCM_SIZEOF_LONG_LONG != 0
1176 case scm_tc7_llvect
:
1177 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1180 if (SCM_REALP (last
) && !SCM_EQ_P (last
, scm_flo0
))
1182 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1185 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1187 if (SCM_REALP (last
) && !SCM_EQ_P (last
, scm_flo0
))
1189 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1192 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1194 if (SCM_COMPLEXP (last
))
1196 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1197 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1200 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1201 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1202 case scm_tc7_vector
:
1204 return SCM_VELTS (v
)[pos
];
1206 { /* enclosed scm_array */
1207 int k
= SCM_ARRAY_NDIM (v
);
1208 SCM res
= scm_make_ra (k
);
1209 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1210 SCM_ARRAY_BASE (res
) = pos
;
1213 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1214 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1215 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1224 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1227 /* Note that args may be a list or an immediate object, depending which
1228 PROC is used (and it's called from C too). */
1229 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1230 (SCM v
, SCM obj
, SCM args
),
1231 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1232 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1233 "@var{new-value}. The value returned by array-set! is unspecified.")
1234 #define FUNC_NAME s_scm_array_set_x
1238 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1241 pos
= scm_aind (v
, args
, FUNC_NAME
);
1242 v
= SCM_ARRAY_V (v
);
1246 unsigned long int length
;
1247 if (SCM_CONSP (args
))
1249 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG3
, FUNC_NAME
);
1250 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1251 pos
= SCM_INUM (SCM_CAR (args
));
1255 SCM_VALIDATE_INUM_COPY (3, args
, pos
);
1257 length
= SCM_INUM (scm_uniform_vector_length (v
));
1258 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1260 switch (SCM_TYP7 (v
))
1263 SCM_WRONG_TYPE_ARG (1, v
);
1266 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1268 SCM_WRONG_NUM_ARGS ();
1269 case scm_tc7_smob
: /* enclosed */
1272 if (SCM_FALSEP (obj
))
1273 SCM_BITVEC_CLR(v
, pos
);
1274 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1275 SCM_BITVEC_SET(v
, pos
);
1277 badobj
:SCM_WRONG_TYPE_ARG (2, obj
);
1279 case scm_tc7_string
:
1280 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1281 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1283 case scm_tc7_byvect
:
1284 if (SCM_CHARP (obj
))
1285 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1286 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1287 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1290 ((unsigned long *) SCM_UVECTOR_BASE (v
))[pos
]
1291 = scm_num2ulong (obj
, SCM_ARG2
, FUNC_NAME
);
1294 ((long *) SCM_UVECTOR_BASE (v
))[pos
]
1295 = scm_num2long (obj
, SCM_ARG2
, FUNC_NAME
);
1298 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1299 ((short *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1301 #if SCM_SIZEOF_LONG_LONG != 0
1302 case scm_tc7_llvect
:
1303 ((long long *) SCM_UVECTOR_BASE (v
))[pos
]
1304 = scm_num2long_long (obj
, SCM_ARG2
, FUNC_NAME
);
1308 ((float *) SCM_UVECTOR_BASE (v
))[pos
]
1309 = (float) scm_num2dbl (obj
, FUNC_NAME
);
1312 ((double *) SCM_UVECTOR_BASE (v
))[pos
]
1313 = scm_num2dbl (obj
, FUNC_NAME
);
1316 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1317 if (SCM_REALP (obj
)) {
1318 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1319 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = 0.0;
1321 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1322 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1325 case scm_tc7_vector
:
1327 SCM_VECTOR_SET (v
, pos
, obj
);
1330 return SCM_UNSPECIFIED
;
1334 /* attempts to unroll an array into a one-dimensional array.
1335 returns the unrolled array or #f if it can't be done. */
1336 /* if strict is not SCM_UNDEFINED, return #f if returned array
1337 wouldn't have contiguous elements. */
1338 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1339 (SCM ra
, SCM strict
),
1340 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1341 "without changing their order (last subscript changing fastest), then\n"
1342 "@code{array-contents} returns that shared array, otherwise it returns\n"
1343 "@code{#f}. All arrays made by @var{make-array} and\n"
1344 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1345 "@var{make-shared-array} may not be.\n\n"
1346 "If the optional argument @var{strict} is provided, a shared array will\n"
1347 "be returned only if its elements are stored internally contiguous in\n"
1349 #define FUNC_NAME s_scm_array_contents
1354 switch SCM_TYP7 (ra
)
1358 case scm_tc7_vector
:
1360 case scm_tc7_string
:
1362 case scm_tc7_byvect
:
1369 #if SCM_SIZEOF_LONG_LONG != 0
1370 case scm_tc7_llvect
:
1375 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1376 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1378 for (k
= 0; k
< ndim
; k
++)
1379 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1380 if (!SCM_UNBNDP (strict
))
1382 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1384 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1386 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1387 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1394 SCM v
= SCM_ARRAY_V (ra
);
1395 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1396 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1400 sra
= scm_make_ra (1);
1401 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1402 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1403 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1404 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1405 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1414 scm_ra2contig (SCM ra
, int copy
)
1419 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1420 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1421 k
= SCM_ARRAY_NDIM (ra
);
1422 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1424 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1426 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1427 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1428 0 == len
% SCM_LONG_BIT
))
1431 ret
= scm_make_ra (k
);
1432 SCM_ARRAY_BASE (ret
) = 0;
1435 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1436 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1437 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1438 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1440 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_prototype (ra
));
1442 scm_array_copy_x (ra
, ret
);
1448 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1449 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1450 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1451 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1452 "binary objects from @var{port-or-fdes}.\n"
1453 "If an end of file is encountered,\n"
1454 "the objects up to that point are put into @var{ura}\n"
1455 "(starting at the beginning) and the remainder of the array is\n"
1457 "The optional arguments @var{start} and @var{end} allow\n"
1458 "a specified region of a vector (or linearized array) to be read,\n"
1459 "leaving the remainder of the vector unchanged.\n\n"
1460 "@code{uniform-array-read!} returns the number of objects read.\n"
1461 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1462 "returned by @code{(current-input-port)}.")
1463 #define FUNC_NAME s_scm_uniform_array_read_x
1465 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1472 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1473 if (SCM_UNBNDP (port_or_fd
))
1474 port_or_fd
= scm_cur_inp
;
1476 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1477 || (SCM_OPINPORTP (port_or_fd
)),
1478 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1479 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1481 : SCM_INUM (scm_uniform_vector_length (v
)));
1487 badarg1
:SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1489 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1490 cra
= scm_ra2contig (ra
, 0);
1491 cstart
+= SCM_ARRAY_BASE (cra
);
1492 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1493 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1494 v
= SCM_ARRAY_V (cra
);
1496 case scm_tc7_string
:
1497 base
= SCM_STRING_CHARS (v
);
1501 base
= (char *) SCM_BITVECTOR_BASE (v
);
1502 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1503 cstart
/= SCM_LONG_BIT
;
1506 case scm_tc7_byvect
:
1507 base
= (char *) SCM_UVECTOR_BASE (v
);
1512 base
= (char *) SCM_UVECTOR_BASE (v
);
1516 base
= (char *) SCM_UVECTOR_BASE (v
);
1517 sz
= sizeof (short);
1519 #if SCM_SIZEOF_LONG_LONG != 0
1520 case scm_tc7_llvect
:
1521 base
= (char *) SCM_UVECTOR_BASE (v
);
1522 sz
= sizeof (long long);
1526 base
= (char *) SCM_UVECTOR_BASE (v
);
1527 sz
= sizeof (float);
1530 base
= (char *) SCM_UVECTOR_BASE (v
);
1531 sz
= sizeof (double);
1534 base
= (char *) SCM_UVECTOR_BASE (v
);
1535 sz
= 2 * sizeof (double);
1540 if (!SCM_UNBNDP (start
))
1543 SCM_NUM2LONG (3, start
);
1545 if (offset
< 0 || offset
>= cend
)
1546 scm_out_of_range (FUNC_NAME
, start
);
1548 if (!SCM_UNBNDP (end
))
1551 SCM_NUM2LONG (4, end
);
1553 if (tend
<= offset
|| tend
> cend
)
1554 scm_out_of_range (FUNC_NAME
, end
);
1559 if (SCM_NIMP (port_or_fd
))
1561 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1562 int remaining
= (cend
- offset
) * sz
;
1563 char *dest
= base
+ (cstart
+ offset
) * sz
;
1565 if (pt
->rw_active
== SCM_PORT_WRITE
)
1566 scm_flush (port_or_fd
);
1568 ans
= cend
- offset
;
1569 while (remaining
> 0)
1571 if (pt
->read_pos
< pt
->read_end
)
1573 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1576 memcpy (dest
, pt
->read_pos
, to_copy
);
1577 pt
->read_pos
+= to_copy
;
1578 remaining
-= to_copy
;
1583 if (scm_fill_input (port_or_fd
) == EOF
)
1585 if (remaining
% sz
!= 0)
1587 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1589 ans
-= remaining
/ sz
;
1596 pt
->rw_active
= SCM_PORT_READ
;
1598 else /* file descriptor. */
1600 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1601 base
+ (cstart
+ offset
) * sz
,
1602 (sz
* (cend
- offset
))));
1606 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1607 ans
*= SCM_LONG_BIT
;
1609 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1610 scm_array_copy_x (cra
, ra
);
1612 return SCM_MAKINUM (ans
);
1616 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1617 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1618 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1619 "Writes all elements of @var{ura} as binary objects to\n"
1620 "@var{port-or-fdes}.\n\n"
1621 "The optional arguments @var{start}\n"
1622 "and @var{end} allow\n"
1623 "a specified region of a vector (or linearized array) to be written.\n\n"
1624 "The number of objects actually written is returned.\n"
1625 "@var{port-or-fdes} may be\n"
1626 "omitted, in which case it defaults to the value returned by\n"
1627 "@code{(current-output-port)}.")
1628 #define FUNC_NAME s_scm_uniform_array_write
1636 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1638 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1639 if (SCM_UNBNDP (port_or_fd
))
1640 port_or_fd
= scm_cur_outp
;
1642 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1643 || (SCM_OPOUTPORTP (port_or_fd
)),
1644 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1645 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1647 : SCM_INUM (scm_uniform_vector_length (v
)));
1653 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1655 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1656 v
= scm_ra2contig (v
, 1);
1657 cstart
= SCM_ARRAY_BASE (v
);
1658 vlen
= (SCM_ARRAY_DIMS (v
)->inc
1659 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1));
1660 v
= SCM_ARRAY_V (v
);
1662 case scm_tc7_string
:
1663 base
= SCM_STRING_CHARS (v
);
1667 base
= (char *) SCM_BITVECTOR_BASE (v
);
1668 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1669 cstart
/= SCM_LONG_BIT
;
1672 case scm_tc7_byvect
:
1673 base
= (char *) SCM_UVECTOR_BASE (v
);
1678 base
= (char *) SCM_UVECTOR_BASE (v
);
1682 base
= (char *) SCM_UVECTOR_BASE (v
);
1683 sz
= sizeof (short);
1685 #if SCM_SIZEOF_LONG_LONG != 0
1686 case scm_tc7_llvect
:
1687 base
= (char *) SCM_UVECTOR_BASE (v
);
1688 sz
= sizeof (long long);
1692 base
= (char *) SCM_UVECTOR_BASE (v
);
1693 sz
= sizeof (float);
1696 base
= (char *) SCM_UVECTOR_BASE (v
);
1697 sz
= sizeof (double);
1700 base
= (char *) SCM_UVECTOR_BASE (v
);
1701 sz
= 2 * sizeof (double);
1706 if (!SCM_UNBNDP (start
))
1709 SCM_NUM2LONG (3, start
);
1711 if (offset
< 0 || offset
>= cend
)
1712 scm_out_of_range (FUNC_NAME
, start
);
1714 if (!SCM_UNBNDP (end
))
1717 SCM_NUM2LONG (4, end
);
1719 if (tend
<= offset
|| tend
> cend
)
1720 scm_out_of_range (FUNC_NAME
, end
);
1725 if (SCM_NIMP (port_or_fd
))
1727 char *source
= base
+ (cstart
+ offset
) * sz
;
1729 ans
= cend
- offset
;
1730 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1732 else /* file descriptor. */
1734 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1735 base
+ (cstart
+ offset
) * sz
,
1736 (sz
* (cend
- offset
))));
1740 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1741 ans
*= SCM_LONG_BIT
;
1743 return SCM_MAKINUM (ans
);
1748 static char cnt_tab
[16] =
1749 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1751 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1752 (SCM b
, SCM bitvector
),
1753 "Return the number of occurrences of the boolean @var{b} in\n"
1755 #define FUNC_NAME s_scm_bit_count
1757 SCM_VALIDATE_BOOL (1, b
);
1758 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1759 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1762 unsigned long int count
= 0;
1763 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1764 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1765 if (SCM_FALSEP (b
)) {
1768 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1771 count
+= cnt_tab
[w
& 0x0f];
1775 return SCM_MAKINUM (count
);
1778 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1779 if (SCM_FALSEP (b
)) {
1789 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1790 (SCM item
, SCM v
, SCM k
),
1791 "Return the index of the first occurrance of @var{item} in bit\n"
1792 "vector @var{v}, starting from @var{k}. If there is no\n"
1793 "@var{item} entry between @var{k} and the end of\n"
1794 "@var{bitvector}, then return @code{#f}. For example,\n"
1797 "(bit-position #t #*000101 0) @result{} 3\n"
1798 "(bit-position #f #*0001111 3) @result{} #f\n"
1800 #define FUNC_NAME s_scm_bit_position
1802 long i
, lenw
, xbits
, pos
;
1803 register unsigned long w
;
1805 SCM_VALIDATE_BOOL (1, item
);
1806 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1807 SCM_VALIDATE_INUM_COPY (3, k
, pos
);
1808 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1810 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1813 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1814 i
= pos
/ SCM_LONG_BIT
;
1815 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1816 if (SCM_FALSEP (item
))
1818 xbits
= (pos
% SCM_LONG_BIT
);
1820 w
= ((w
>> xbits
) << xbits
);
1821 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1824 if (w
&& (i
== lenw
))
1825 w
= ((w
<< xbits
) >> xbits
);
1831 return SCM_MAKINUM (pos
);
1836 return SCM_MAKINUM (pos
+ 1);
1839 return SCM_MAKINUM (pos
+ 2);
1841 return SCM_MAKINUM (pos
+ 3);
1848 pos
+= SCM_LONG_BIT
;
1849 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1850 if (SCM_FALSEP (item
))
1858 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1859 (SCM v
, SCM kv
, SCM obj
),
1860 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1861 "selecting the entries to change. The return value is\n"
1864 "If @var{kv} is a bit vector, then those entries where it has\n"
1865 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1866 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1867 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1868 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1871 "(define bv #*01000010)\n"
1872 "(bit-set*! bv #*10010001 #t)\n"
1874 "@result{} #*11010011\n"
1877 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1878 "they're indexes into @var{v} which are set to @var{obj}.\n"
1881 "(define bv #*01000010)\n"
1882 "(bit-set*! bv #u(5 2 7) #t)\n"
1884 "@result{} #*01100111\n"
1886 #define FUNC_NAME s_scm_bit_set_star_x
1888 register long i
, k
, vlen
;
1889 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1890 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1891 switch SCM_TYP7 (kv
)
1894 badarg2
:SCM_WRONG_TYPE_ARG (2, kv
);
1896 vlen
= SCM_BITVECTOR_LENGTH (v
);
1897 if (SCM_FALSEP (obj
))
1898 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1900 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1902 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1903 SCM_BITVEC_CLR(v
, k
);
1905 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1906 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1908 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1910 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1911 SCM_BITVEC_SET(v
, k
);
1914 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1917 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1918 if (SCM_FALSEP (obj
))
1919 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1920 SCM_BITVECTOR_BASE (v
) [k
] &= ~SCM_BITVECTOR_BASE (kv
) [k
];
1921 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1922 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1923 SCM_BITVECTOR_BASE (v
) [k
] |= SCM_BITVECTOR_BASE (kv
) [k
];
1928 return SCM_UNSPECIFIED
;
1933 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1934 (SCM v
, SCM kv
, SCM obj
),
1935 "Return a count of how many entries in bit vector @var{v} are\n"
1936 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1939 "If @var{kv} is a bit vector, then those entries where it has\n"
1940 "@code{#t} are the ones in @var{v} which are considered.\n"
1941 "@var{kv} and @var{v} must be the same length.\n"
1943 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1944 "it's the indexes in @var{v} to consider.\n"
1949 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1950 "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n"
1952 #define FUNC_NAME s_scm_bit_count_star
1954 register long i
, vlen
, count
= 0;
1955 register unsigned long k
;
1958 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1959 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1960 switch SCM_TYP7 (kv
)
1964 SCM_WRONG_TYPE_ARG (2, kv
);
1966 vlen
= SCM_BITVECTOR_LENGTH (v
);
1967 if (SCM_FALSEP (obj
))
1968 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1970 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1972 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1973 if (!SCM_BITVEC_REF(v
, k
))
1976 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1977 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1979 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1981 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1982 if (SCM_BITVEC_REF (v
, k
))
1986 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1989 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1990 if (0 == SCM_BITVECTOR_LENGTH (v
))
1992 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1993 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1994 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1995 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1996 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
2000 count
+= cnt_tab
[k
& 0x0f];
2002 return SCM_MAKINUM (count
);
2004 /* urg. repetitive (see above.) */
2005 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
2008 return SCM_MAKINUM (count
);
2013 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2015 "Modify the bit vector @var{v} by replacing each element with\n"
2017 #define FUNC_NAME s_scm_bit_invert_x
2021 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
2023 k
= SCM_BITVECTOR_LENGTH (v
);
2024 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
2025 SCM_BITVECTOR_BASE (v
) [k
] = ~SCM_BITVECTOR_BASE (v
) [k
];
2027 return SCM_UNSPECIFIED
;
2033 scm_istr2bve (char *str
, long len
)
2035 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
2036 long *data
= (long *) SCM_VELTS (v
);
2037 register unsigned long mask
;
2040 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2043 j
= len
- k
* SCM_LONG_BIT
;
2044 if (j
> SCM_LONG_BIT
)
2046 for (mask
= 1L; j
--; mask
<<= 1)
2064 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2066 register SCM res
= SCM_EOL
;
2067 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2069 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2071 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2072 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2077 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2085 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2092 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2094 "Return a list consisting of all the elements, in order, of\n"
2096 #define FUNC_NAME s_scm_array_to_list
2100 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2104 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
2106 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2107 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2108 case scm_tc7_vector
:
2110 return scm_vector_to_list (v
);
2111 case scm_tc7_string
:
2112 return scm_string_to_list (v
);
2115 long *data
= (long *) SCM_VELTS (v
);
2116 register unsigned long mask
;
2117 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2118 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2119 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2120 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2121 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2124 case scm_tc7_byvect
:
2126 signed char *data
= (signed char *) SCM_VELTS (v
);
2127 unsigned long k
= SCM_UVECTOR_LENGTH (v
);
2129 res
= scm_cons (SCM_MAKINUM (data
[--k
]), res
);
2134 long *data
= (long *)SCM_VELTS(v
);
2135 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2136 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2141 long *data
= (long *)SCM_VELTS(v
);
2142 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2143 res
= scm_cons(scm_long2num(data
[k
]), res
);
2148 short *data
= (short *)SCM_VELTS(v
);
2149 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2150 res
= scm_cons(scm_short2num (data
[k
]), res
);
2153 #if SCM_SIZEOF_LONG_LONG != 0
2154 case scm_tc7_llvect
:
2156 long long *data
= (long long *)SCM_VELTS(v
);
2157 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2158 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2164 float *data
= (float *) SCM_VELTS (v
);
2165 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2166 res
= scm_cons (scm_make_real (data
[k
]), res
);
2171 double *data
= (double *) SCM_VELTS (v
);
2172 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2173 res
= scm_cons (scm_make_real (data
[k
]), res
);
2178 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2179 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2180 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2188 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2190 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2191 (SCM ndim
, SCM prot
, SCM lst
),
2192 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2193 "Return a uniform array of the type indicated by prototype\n"
2194 "@var{prot} with elements the same as those of @var{lst}.\n"
2195 "Elements must be of the appropriate type, no coercions are\n"
2197 #define FUNC_NAME s_scm_list_to_uniform_array
2204 SCM_VALIDATE_INUM_COPY (1, ndim
, k
);
2207 n
= scm_ilength (row
);
2208 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2209 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2211 row
= SCM_CAR (row
);
2213 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2215 if (SCM_NULLP (shp
))
2217 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2218 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2221 if (!SCM_ARRAYP (ra
))
2223 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2224 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2225 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2228 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2231 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2237 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2239 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2240 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2243 return (SCM_NULLP (lst
));
2244 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2248 if (!SCM_CONSP (lst
))
2250 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2252 lst
= SCM_CDR (lst
);
2254 if (!SCM_NULLP (lst
))
2261 if (!SCM_CONSP (lst
))
2263 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2265 lst
= SCM_CDR (lst
);
2267 if (!SCM_NULLP (lst
))
2275 rapr1 (SCM ra
, unsigned long j
, unsigned long k
, SCM port
, scm_print_state
*pstate
)
2278 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2280 : SCM_INUM (scm_uniform_vector_length (ra
)));
2283 switch SCM_TYP7 (ra
)
2288 SCM_ARRAY_BASE (ra
) = j
;
2290 scm_iprin1 (ra
, port
, pstate
);
2291 for (j
+= inc
; n
-- > 0; j
+= inc
)
2293 scm_putc (' ', port
);
2294 SCM_ARRAY_BASE (ra
) = j
;
2295 scm_iprin1 (ra
, port
, pstate
);
2299 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2302 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2303 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2305 scm_putc ('(', port
);
2306 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2307 scm_puts (") ", port
);
2310 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2311 { /* could be zero size. */
2312 scm_putc ('(', port
);
2313 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2314 scm_putc (')', port
);
2318 if (SCM_ARRAY_NDIM (ra
) > 0)
2319 { /* Could be zero-dimensional */
2320 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2321 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2325 ra
= SCM_ARRAY_V (ra
);
2328 /* scm_tc7_bvect and scm_tc7_llvect only? */
2330 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2331 for (j
+= inc
; n
-- > 0; j
+= inc
)
2333 scm_putc (' ', port
);
2334 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2337 case scm_tc7_string
:
2339 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2340 if (SCM_WRITINGP (pstate
))
2341 for (j
+= inc
; n
-- > 0; j
+= inc
)
2343 scm_putc (' ', port
);
2344 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2347 for (j
+= inc
; n
-- > 0; j
+= inc
)
2348 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2350 case scm_tc7_byvect
:
2352 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2353 for (j
+= inc
; n
-- > 0; j
+= inc
)
2355 scm_putc (' ', port
);
2356 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2366 /* intprint can't handle >= 2^31. */
2367 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2368 scm_puts (str
, port
);
2370 for (j
+= inc
; n
-- > 0; j
+= inc
)
2372 scm_putc (' ', port
);
2373 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2374 scm_puts (str
, port
);
2379 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2380 for (j
+= inc
; n
-- > 0; j
+= inc
)
2382 scm_putc (' ', port
);
2383 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2389 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2390 for (j
+= inc
; n
-- > 0; j
+= inc
)
2392 scm_putc (' ', port
);
2393 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2400 SCM z
= scm_make_real (1.0);
2401 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2402 scm_print_real (z
, port
, pstate
);
2403 for (j
+= inc
; n
-- > 0; j
+= inc
)
2405 scm_putc (' ', port
);
2406 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2407 scm_print_real (z
, port
, pstate
);
2414 SCM z
= scm_make_real (1.0 / 3.0);
2415 SCM_REAL_VALUE (z
) = ((double *) 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
) = ((double *) SCM_VELTS (ra
))[j
];
2421 scm_print_real (z
, port
, pstate
);
2428 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2429 SCM_REAL_VALUE (z
) =
2430 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2431 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2432 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2434 for (j
+= inc
; n
-- > 0; j
+= inc
)
2436 scm_putc (' ', port
);
2438 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2439 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2440 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2451 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2454 unsigned long base
= 0;
2455 scm_putc ('#', port
);
2461 long ndim
= SCM_ARRAY_NDIM (v
);
2462 base
= SCM_ARRAY_BASE (v
);
2463 v
= SCM_ARRAY_V (v
);
2467 scm_puts ("<enclosed-array ", port
);
2468 rapr1 (exp
, base
, 0, port
, pstate
);
2469 scm_putc ('>', port
);
2474 scm_intprint (ndim
, 10, port
);
2479 if (SCM_EQ_P (exp
, v
))
2480 { /* a uve, not an scm_array */
2481 register long i
, j
, w
;
2482 scm_putc ('*', port
);
2483 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2485 scm_t_bits w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2486 for (j
= SCM_LONG_BIT
; j
; j
--)
2488 scm_putc (w
& 1 ? '1' : '0', port
);
2492 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2495 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2498 scm_putc (w
& 1 ? '1' : '0', port
);
2505 scm_putc ('b', port
);
2507 case scm_tc7_string
:
2508 scm_putc ('a', port
);
2510 case scm_tc7_byvect
:
2511 scm_putc ('y', port
);
2514 scm_putc ('u', port
);
2517 scm_putc ('e', port
);
2520 scm_putc ('h', port
);
2522 #if SCM_SIZEOF_LONG_LONG != 0
2523 case scm_tc7_llvect
:
2524 scm_putc ('l', port
);
2528 scm_putc ('s', port
);
2531 scm_putc ('i', port
);
2534 scm_putc ('c', port
);
2537 scm_putc ('(', port
);
2538 rapr1 (exp
, base
, 0, port
, pstate
);
2539 scm_putc (')', port
);
2543 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2545 "Return an object that would produce an array of the same type\n"
2546 "as @var{array}, if used as the @var{prototype} for\n"
2547 "@code{make-uniform-array}.")
2548 #define FUNC_NAME s_scm_array_prototype
2551 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2553 switch SCM_TYP7 (ra
)
2556 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
2558 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2560 return SCM_UNSPECIFIED
;
2561 ra
= SCM_ARRAY_V (ra
);
2563 case scm_tc7_vector
:
2568 case scm_tc7_string
:
2569 return SCM_MAKE_CHAR ('a');
2570 case scm_tc7_byvect
:
2571 return SCM_MAKE_CHAR ('\0');
2573 return SCM_MAKINUM (1L);
2575 return SCM_MAKINUM (-1L);
2577 return scm_str2symbol ("s");
2578 #if SCM_SIZEOF_LONG_LONG != 0
2579 case scm_tc7_llvect
:
2580 return scm_str2symbol ("l");
2583 return scm_make_real (1.0);
2585 return exactly_one_third
;
2587 return scm_make_complex (0.0, 1.0);
2594 array_mark (SCM ptr
)
2596 return SCM_ARRAY_V (ptr
);
2601 array_free (SCM ptr
)
2603 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2604 (sizeof (scm_t_array
)
2605 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2613 scm_tc16_array
= scm_make_smob_type ("array", 0);
2614 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2615 scm_set_smob_free (scm_tc16_array
, array_free
);
2616 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2617 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2618 exactly_one_third
= scm_permanent_object (scm_make_ratio (SCM_MAKINUM (1),
2620 scm_add_feature ("array");
2621 #include "libguile/unif.x"