1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 This file has code for arrays in lots of variants (double, integer,
45 unsigned etc. ). It suffers from hugely repetitive code because
46 there is similar (but different) code for every variant included. (urg.)
60 #include "libguile/_scm.h"
61 #include "libguile/chars.h"
62 #include "libguile/eval.h"
63 #include "libguile/fports.h"
64 #include "libguile/smob.h"
65 #include "libguile/strop.h"
66 #include "libguile/feature.h"
67 #include "libguile/root.h"
68 #include "libguile/strings.h"
69 #include "libguile/vectors.h"
71 #include "libguile/validate.h"
72 #include "libguile/unif.h"
73 #include "libguile/ramap.h"
84 /* The set of uniform scm_vector types is:
86 * unsigned char string
93 * complex double cvect
98 scm_t_bits scm_tc16_array
;
100 /* return the size of an element in a uniform array or 0 if type not
103 scm_uniform_element_size (SCM obj
)
107 switch (SCM_TYP7 (obj
))
112 result
= sizeof (long);
116 result
= sizeof (char);
120 result
= sizeof (short);
123 #if SCM_SIZEOF_LONG_LONG != 0
125 result
= sizeof (long long);
130 result
= sizeof (float);
134 result
= sizeof (double);
138 result
= 2 * sizeof (double);
147 /* Silly function used not to modify the semantics of the silly
148 * prototype system in order to be backward compatible.
153 if (!SCM_REALP (obj
))
157 double x
= SCM_REAL_VALUE (obj
);
159 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
164 scm_make_uve (long k
, SCM prot
)
165 #define FUNC_NAME "scm_make_uve"
170 if (SCM_EQ_P (prot
, SCM_BOOL_T
))
175 scm_long2num (k
), k
<= SCM_BITVECTOR_MAX_LENGTH
);
176 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
177 v
= scm_cell (SCM_MAKE_BITVECTOR_TAG (k
),
178 (scm_t_bits
) scm_gc_malloc (i
, "vector"));
181 v
= scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
184 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
186 i
= sizeof (char) * k
;
187 type
= scm_tc7_byvect
;
189 else if (SCM_CHARP (prot
))
191 i
= sizeof (char) * k
;
192 return scm_allocate_string (i
);
194 else if (SCM_INUMP (prot
))
196 i
= sizeof (long) * k
;
197 if (SCM_INUM (prot
) > 0)
198 type
= scm_tc7_uvect
;
200 type
= scm_tc7_ivect
;
202 else if (SCM_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
206 s
= SCM_SYMBOL_CHARS (prot
)[0];
209 i
= sizeof (short) * k
;
210 type
= scm_tc7_svect
;
212 #if SCM_SIZEOF_LONG_LONG != 0
215 i
= sizeof (long long) * k
;
216 type
= scm_tc7_llvect
;
221 return scm_c_make_vector (k
, SCM_UNDEFINED
);
224 else if (!SCM_INEXACTP (prot
))
225 /* Huge non-unif vectors are NOT supported. */
226 /* no special scm_vector */
227 return scm_c_make_vector (k
, SCM_UNDEFINED
);
228 else if (singp (prot
))
230 i
= sizeof (float) * k
;
231 type
= scm_tc7_fvect
;
233 else if (SCM_COMPLEXP (prot
))
235 i
= 2 * sizeof (double) * k
;
236 type
= scm_tc7_cvect
;
240 i
= sizeof (double) * k
;
241 type
= scm_tc7_dvect
;
244 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_UVECTOR_MAX_LENGTH
);
246 return scm_cell (SCM_MAKE_UVECTOR_TAG (k
, type
),
247 (scm_t_bits
) scm_gc_malloc (i
, "vector"));
252 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
254 "Return the number of elements in @var{uve}.")
255 #define FUNC_NAME s_scm_uniform_vector_length
257 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
261 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
264 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v
));
266 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
268 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
276 #if SCM_SIZEOF_LONG_LONG != 0
279 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v
));
284 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
286 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
287 "not. The @var{prototype} argument is used with uniform arrays\n"
288 "and is described elsewhere.")
289 #define FUNC_NAME s_scm_array_p
293 nprot
= SCM_UNBNDP (prot
);
298 while (SCM_TYP7 (v
) == scm_tc7_smob
)
309 return SCM_BOOL(nprot
);
314 switch (SCM_TYP7 (v
))
317 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
319 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
321 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
323 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
325 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
328 protp
= SCM_SYMBOLP (prot
)
329 && (1 == SCM_SYMBOL_LENGTH (prot
))
330 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
331 #if SCM_SIZEOF_LONG_LONG != 0
333 protp
= SCM_SYMBOLP (prot
)
334 && (1 == SCM_SYMBOL_LENGTH (prot
))
335 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
338 protp
= singp (prot
);
340 protp
= SCM_REALP(prot
);
342 protp
= SCM_COMPLEXP(prot
);
345 protp
= SCM_NULLP(prot
);
350 return SCM_BOOL(protp
);
356 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
358 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
359 "not an array, @code{0} is returned.")
360 #define FUNC_NAME s_scm_array_rank
364 switch (SCM_TYP7 (ra
))
377 #if SCM_SIZEOF_LONG_LONG != 0
381 return SCM_MAKINUM (1L);
384 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
391 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
393 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
394 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
396 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
398 #define FUNC_NAME s_scm_array_dimensions
405 switch (SCM_TYP7 (ra
))
420 #if SCM_SIZEOF_LONG_LONG != 0
423 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
425 if (!SCM_ARRAYP (ra
))
427 k
= SCM_ARRAY_NDIM (ra
);
428 s
= SCM_ARRAY_DIMS (ra
);
430 res
= scm_cons (s
[k
].lbnd
431 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
432 SCM_MAKINUM (s
[k
].ubnd
),
434 : SCM_MAKINUM (1 + s
[k
].ubnd
),
442 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
444 "Return the root vector of a shared array.")
445 #define FUNC_NAME s_scm_shared_array_root
447 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
448 return SCM_ARRAY_V (ra
);
453 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
455 "Return the root vector index of the first element in the array.")
456 #define FUNC_NAME s_scm_shared_array_offset
458 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
459 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
464 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
466 "For each dimension, return the distance between elements in the root vector.")
467 #define FUNC_NAME s_scm_shared_array_increments
472 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
473 k
= SCM_ARRAY_NDIM (ra
);
474 s
= SCM_ARRAY_DIMS (ra
);
476 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
482 static char s_bad_ind
[] = "Bad scm_array index";
486 scm_aind (SCM ra
, SCM args
, const char *what
)
487 #define FUNC_NAME what
491 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
492 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
493 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
494 if (SCM_INUMP (args
))
497 scm_error_num_args_subr (what
);
498 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
500 while (k
&& !SCM_NULLP (args
))
502 ind
= SCM_CAR (args
);
503 args
= SCM_CDR (args
);
504 if (!SCM_INUMP (ind
))
505 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
507 if (j
< s
->lbnd
|| j
> s
->ubnd
)
508 scm_out_of_range (what
, ind
);
509 pos
+= (j
- s
->lbnd
) * (s
->inc
);
513 if (k
!= 0 || !SCM_NULLP (args
))
514 scm_error_num_args_subr (what
);
522 scm_make_ra (int ndim
)
526 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_tc16_array
,
527 scm_gc_malloc ((sizeof (scm_t_array
) +
528 ndim
* sizeof (scm_t_array_dim
)),
530 SCM_ARRAY_V (ra
) = scm_nullvect
;
535 static char s_bad_spec
[] = "Bad scm_array dimension";
536 /* Increments will still need to be set. */
540 scm_shap2ra (SCM args
, const char *what
)
544 int ndim
= scm_ilength (args
);
546 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
548 ra
= scm_make_ra (ndim
);
549 SCM_ARRAY_BASE (ra
) = 0;
550 s
= SCM_ARRAY_DIMS (ra
);
551 for (; !SCM_NULLP (args
); s
++, args
= SCM_CDR (args
))
553 spec
= SCM_CAR (args
);
554 if (SCM_INUMP (spec
))
556 if (SCM_INUM (spec
) < 0)
557 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
559 s
->ubnd
= SCM_INUM (spec
) - 1;
564 if (!SCM_CONSP (spec
) || !SCM_INUMP (SCM_CAR (spec
)))
565 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
566 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
569 || !SCM_INUMP (SCM_CAR (sp
))
570 || !SCM_NULLP (SCM_CDR (sp
)))
571 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
572 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
579 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
580 (SCM dims
, SCM prot
, SCM fill
),
581 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
582 "Create and return a uniform array or vector of type\n"
583 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
584 "length @var{length}. If @var{fill} is supplied, it's used to\n"
585 "fill the array, otherwise @var{prototype} is used.")
586 #define FUNC_NAME s_scm_dimensions_to_uniform_array
589 unsigned long rlen
= 1;
593 if (SCM_INUMP (dims
))
595 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
596 if (!SCM_UNBNDP (fill
))
597 scm_array_fill_x (answer
, fill
);
598 else if (SCM_SYMBOLP (prot
))
599 scm_array_fill_x (answer
, SCM_MAKINUM (0));
601 scm_array_fill_x (answer
, prot
);
605 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
606 dims
, SCM_ARG1
, FUNC_NAME
);
607 ra
= scm_shap2ra (dims
, FUNC_NAME
);
608 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
609 s
= SCM_ARRAY_DIMS (ra
);
610 k
= SCM_ARRAY_NDIM (ra
);
615 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
616 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
619 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
621 if (!SCM_UNBNDP (fill
))
622 scm_array_fill_x (ra
, fill
);
623 else if (SCM_SYMBOLP (prot
))
624 scm_array_fill_x (ra
, SCM_MAKINUM (0));
626 scm_array_fill_x (ra
, prot
);
628 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
629 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
630 return SCM_ARRAY_V (ra
);
637 scm_ra_set_contp (SCM ra
)
639 size_t k
= SCM_ARRAY_NDIM (ra
);
642 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
645 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
647 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
650 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
651 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
654 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
658 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
659 (SCM oldra
, SCM mapfunc
, SCM dims
),
660 "@code{make-shared-array} can be used to create shared subarrays of other\n"
661 "arrays. The @var{mapper} is a function that translates coordinates in\n"
662 "the new array into coordinates in the old array. A @var{mapper} must be\n"
663 "linear, and its range must stay within the bounds of the old array, but\n"
664 "it can be otherwise arbitrary. A simple example:\n"
666 "(define fred (make-array #f 8 8))\n"
667 "(define freds-diagonal\n"
668 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
669 "(array-set! freds-diagonal 'foo 3)\n"
670 "(array-ref fred 3 3) @result{} foo\n"
671 "(define freds-center\n"
672 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
673 "(array-ref freds-center 0 0) @result{} foo\n"
675 #define FUNC_NAME s_scm_make_shared_array
681 long old_min
, new_min
, old_max
, new_max
;
684 SCM_VALIDATE_REST_ARGUMENT (dims
);
685 SCM_VALIDATE_ARRAY (1, oldra
);
686 SCM_VALIDATE_PROC (2, mapfunc
);
687 ra
= scm_shap2ra (dims
, FUNC_NAME
);
688 if (SCM_ARRAYP (oldra
))
690 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
691 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
692 s
= SCM_ARRAY_DIMS (oldra
);
693 k
= SCM_ARRAY_NDIM (oldra
);
697 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
699 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
704 SCM_ARRAY_V (ra
) = oldra
;
706 old_max
= SCM_INUM (scm_uniform_vector_length (oldra
)) - 1;
709 s
= SCM_ARRAY_DIMS (ra
);
710 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
712 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
713 if (s
[k
].ubnd
< s
[k
].lbnd
)
715 if (1 == SCM_ARRAY_NDIM (ra
))
716 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
718 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
722 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
723 if (SCM_ARRAYP (oldra
))
724 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
727 if (SCM_NINUMP (imap
))
730 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
731 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
732 imap
= SCM_CAR (imap
);
736 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
738 k
= SCM_ARRAY_NDIM (ra
);
741 if (s
[k
].ubnd
> s
[k
].lbnd
)
743 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
744 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
745 if (SCM_ARRAYP (oldra
))
747 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
750 if (SCM_NINUMP (imap
))
752 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
753 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
754 imap
= SCM_CAR (imap
);
756 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
760 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
762 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
765 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
766 indptr
= SCM_CDR (indptr
);
768 if (old_min
> new_min
|| old_max
< new_max
)
769 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
770 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
772 SCM v
= SCM_ARRAY_V (ra
);
773 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
774 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
776 if (s
->ubnd
< s
->lbnd
)
777 return scm_make_uve (0L, scm_array_prototype (ra
));
779 scm_ra_set_contp (ra
);
785 /* args are RA . DIMS */
786 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
788 "Return an array sharing contents with @var{array}, but with\n"
789 "dimensions arranged in a different order. There must be one\n"
790 "@var{dim} argument for each dimension of @var{array}.\n"
791 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
792 "and the rank of the array to be returned. Each integer in that\n"
793 "range must appear at least once in the argument list.\n"
795 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
796 "dimensions in the array to be returned, their positions in the\n"
797 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
798 "may have the same value, in which case the returned array will\n"
799 "have smaller rank than @var{array}.\n"
802 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
803 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
804 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
805 " #2((a 4) (b 5) (c 6))\n"
807 #define FUNC_NAME s_scm_transpose_array
810 SCM
const *ve
= &vargs
;
811 scm_t_array_dim
*s
, *r
;
814 SCM_VALIDATE_REST_ARGUMENT (args
);
815 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
816 switch (SCM_TYP7 (ra
))
819 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
829 #if SCM_SIZEOF_LONG_LONG != 0
832 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
833 SCM_WRONG_NUM_ARGS ();
834 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CAR (args
));
835 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
836 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
839 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
840 vargs
= scm_vector (args
);
841 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
842 SCM_WRONG_NUM_ARGS ();
843 ve
= SCM_VELTS (vargs
);
845 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
847 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
849 i
= SCM_INUM (ve
[k
]);
850 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
851 scm_out_of_range (FUNC_NAME
, ve
[k
]);
856 res
= scm_make_ra (ndim
);
857 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
858 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
861 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
862 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
864 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
866 i
= SCM_INUM (ve
[k
]);
867 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
868 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
869 if (r
->ubnd
< r
->lbnd
)
878 if (r
->ubnd
> s
->ubnd
)
880 if (r
->lbnd
< s
->lbnd
)
882 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
889 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
890 scm_ra_set_contp (res
);
896 /* args are RA . AXES */
897 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
899 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
900 "the rank of @var{array}. @var{enclose-array} returns an array\n"
901 "resembling an array of shared arrays. The dimensions of each shared\n"
902 "array are the same as the @var{dim}th dimensions of the original array,\n"
903 "the dimensions of the outer array are the same as those of the original\n"
904 "array that did not match a @var{dim}.\n\n"
905 "An enclosed array is not a general Scheme array. Its elements may not\n"
906 "be set using @code{array-set!}. Two references to the same element of\n"
907 "an enclosed array will be @code{equal?} but will not in general be\n"
908 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
909 "enclosed array is unspecified.\n\n"
912 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
913 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
914 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
915 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
917 #define FUNC_NAME s_scm_enclose_array
919 SCM axv
, res
, ra_inr
;
920 scm_t_array_dim vdim
, *s
= &vdim
;
921 int ndim
, j
, k
, ninr
, noutr
;
923 SCM_VALIDATE_REST_ARGUMENT (axes
);
924 if (SCM_NULLP (axes
))
925 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
926 ninr
= scm_ilength (axes
);
928 SCM_WRONG_NUM_ARGS ();
929 ra_inr
= scm_make_ra (ninr
);
930 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
934 badarg1
:SCM_WRONG_TYPE_ARG (1, ra
);
946 #if SCM_SIZEOF_LONG_LONG != 0
950 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
952 SCM_ARRAY_V (ra_inr
) = ra
;
953 SCM_ARRAY_BASE (ra_inr
) = 0;
957 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
958 s
= SCM_ARRAY_DIMS (ra
);
959 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
960 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
961 ndim
= SCM_ARRAY_NDIM (ra
);
966 SCM_WRONG_NUM_ARGS ();
967 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
968 res
= scm_make_ra (noutr
);
969 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
970 SCM_ARRAY_V (res
) = ra_inr
;
971 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
973 if (!SCM_INUMP (SCM_CAR (axes
)))
974 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
975 j
= SCM_INUM (SCM_CAR (axes
));
976 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
977 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
978 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
979 SCM_STRING_CHARS (axv
)[j
] = 1;
981 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
983 while (SCM_STRING_CHARS (axv
)[j
])
985 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
986 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
987 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
989 scm_ra_set_contp (ra_inr
);
990 scm_ra_set_contp (res
);
997 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
999 "Return @code{#t} if its arguments would be acceptable to\n"
1000 "@code{array-ref}.")
1001 #define FUNC_NAME s_scm_array_in_bounds_p
1009 SCM_VALIDATE_REST_ARGUMENT (args
);
1010 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1011 if (SCM_NIMP (args
))
1014 ind
= SCM_CAR (args
);
1015 args
= SCM_CDR (args
);
1016 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
1017 pos
= SCM_INUM (ind
);
1023 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1024 wna
: SCM_WRONG_NUM_ARGS ();
1026 k
= SCM_ARRAY_NDIM (v
);
1027 s
= SCM_ARRAY_DIMS (v
);
1028 pos
= SCM_ARRAY_BASE (v
);
1031 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1038 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1040 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1043 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1044 if (!(--k
&& SCM_NIMP (args
)))
1046 ind
= SCM_CAR (args
);
1047 args
= SCM_CDR (args
);
1049 if (!SCM_INUMP (ind
))
1050 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
1052 SCM_ASRTGO (0 == k
, wna
);
1053 v
= SCM_ARRAY_V (v
);
1056 case scm_tc7_string
:
1057 case scm_tc7_byvect
:
1064 #if SCM_SIZEOF_LONG_LONG != 0
1065 case scm_tc7_llvect
:
1067 case scm_tc7_vector
:
1070 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1071 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1072 return SCM_BOOL(pos
>= 0 && pos
< length
);
1079 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1082 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1084 "@deffnx {Scheme Procedure} array-ref v . args\n"
1085 "Return the element at the @code{(index1, index2)} element in\n"
1087 #define FUNC_NAME s_scm_uniform_vector_ref
1093 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1096 else if (SCM_ARRAYP (v
))
1098 pos
= scm_aind (v
, args
, FUNC_NAME
);
1099 v
= SCM_ARRAY_V (v
);
1103 unsigned long int length
;
1104 if (SCM_NIMP (args
))
1106 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1107 pos
= SCM_INUM (SCM_CAR (args
));
1108 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1112 SCM_VALIDATE_INUM (2, args
);
1113 pos
= SCM_INUM (args
);
1115 length
= SCM_INUM (scm_uniform_vector_length (v
));
1116 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1121 if (SCM_NULLP (args
))
1124 SCM_WRONG_TYPE_ARG (1, v
);
1128 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1130 SCM_WRONG_NUM_ARGS ();
1133 int k
= SCM_ARRAY_NDIM (v
);
1134 SCM res
= scm_make_ra (k
);
1135 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1136 SCM_ARRAY_BASE (res
) = pos
;
1139 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1140 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1141 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1146 if (SCM_BITVEC_REF (v
, pos
))
1150 case scm_tc7_string
:
1151 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1152 case scm_tc7_byvect
:
1153 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1155 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1157 return scm_long2num (((signed long *) SCM_VELTS (v
))[pos
]);
1160 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1161 #if SCM_SIZEOF_LONG_LONG != 0
1162 case scm_tc7_llvect
:
1163 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1167 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1169 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1171 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1172 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1173 case scm_tc7_vector
:
1175 return SCM_VELTS (v
)[pos
];
1180 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1181 tries to recycle conses. (Make *sure* you want them recycled.) */
1184 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1185 #define FUNC_NAME "scm_cvref"
1190 SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1192 if (SCM_BITVEC_REF(v
, pos
))
1196 case scm_tc7_string
:
1197 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1198 case scm_tc7_byvect
:
1199 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1201 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1203 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1205 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1206 #if SCM_SIZEOF_LONG_LONG != 0
1207 case scm_tc7_llvect
:
1208 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1211 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1213 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1216 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1218 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1220 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1223 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1225 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1227 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1228 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1231 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1232 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1233 case scm_tc7_vector
:
1235 return SCM_VELTS (v
)[pos
];
1237 { /* enclosed scm_array */
1238 int k
= SCM_ARRAY_NDIM (v
);
1239 SCM res
= scm_make_ra (k
);
1240 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1241 SCM_ARRAY_BASE (res
) = pos
;
1244 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1245 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1246 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1255 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1258 /* Note that args may be a list or an immediate object, depending which
1259 PROC is used (and it's called from C too). */
1260 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1261 (SCM v
, SCM obj
, SCM args
),
1262 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1263 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1264 "@var{new-value}. The value returned by array-set! is unspecified.")
1265 #define FUNC_NAME s_scm_array_set_x
1269 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1272 pos
= scm_aind (v
, args
, FUNC_NAME
);
1273 v
= SCM_ARRAY_V (v
);
1277 unsigned long int length
;
1278 if (SCM_CONSP (args
))
1280 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG3
, FUNC_NAME
);
1281 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1282 pos
= SCM_INUM (SCM_CAR (args
));
1286 SCM_VALIDATE_INUM_COPY (3, args
, pos
);
1288 length
= SCM_INUM (scm_uniform_vector_length (v
));
1289 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1291 switch (SCM_TYP7 (v
))
1294 SCM_WRONG_TYPE_ARG (1, v
);
1297 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1299 SCM_WRONG_NUM_ARGS ();
1300 case scm_tc7_smob
: /* enclosed */
1303 if (SCM_FALSEP (obj
))
1304 SCM_BITVEC_CLR(v
, pos
);
1305 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1306 SCM_BITVEC_SET(v
, pos
);
1308 badobj
:SCM_WRONG_TYPE_ARG (2, obj
);
1310 case scm_tc7_string
:
1311 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1312 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1314 case scm_tc7_byvect
:
1315 if (SCM_CHARP (obj
))
1316 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1317 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1318 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1321 ((unsigned long *) SCM_UVECTOR_BASE (v
))[pos
]
1322 = scm_num2ulong (obj
, SCM_ARG2
, FUNC_NAME
);
1325 ((long *) SCM_UVECTOR_BASE (v
))[pos
]
1326 = scm_num2long (obj
, SCM_ARG2
, FUNC_NAME
);
1329 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1330 ((short *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1332 #if SCM_SIZEOF_LONG_LONG != 0
1333 case scm_tc7_llvect
:
1334 ((long long *) SCM_UVECTOR_BASE (v
))[pos
]
1335 = scm_num2long_long (obj
, SCM_ARG2
, FUNC_NAME
);
1339 ((float *) SCM_UVECTOR_BASE (v
))[pos
]
1340 = (float) scm_num2dbl (obj
, FUNC_NAME
);
1343 ((double *) SCM_UVECTOR_BASE (v
))[pos
]
1344 = scm_num2dbl (obj
, FUNC_NAME
);
1347 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1348 if (SCM_REALP (obj
)) {
1349 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1350 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = 0.0;
1352 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1353 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1356 case scm_tc7_vector
:
1358 SCM_VECTOR_SET (v
, pos
, obj
);
1361 return SCM_UNSPECIFIED
;
1365 /* attempts to unroll an array into a one-dimensional array.
1366 returns the unrolled array or #f if it can't be done. */
1367 /* if strict is not SCM_UNDEFINED, return #f if returned array
1368 wouldn't have contiguous elements. */
1369 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1370 (SCM ra
, SCM strict
),
1371 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1372 "without changing their order (last subscript changing fastest), then\n"
1373 "@code{array-contents} returns that shared array, otherwise it returns\n"
1374 "@code{#f}. All arrays made by @var{make-array} and\n"
1375 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1376 "@var{make-shared-array} may not be.\n\n"
1377 "If the optional argument @var{strict} is provided, a shared array will\n"
1378 "be returned only if its elements are stored internally contiguous in\n"
1380 #define FUNC_NAME s_scm_array_contents
1385 switch SCM_TYP7 (ra
)
1389 case scm_tc7_vector
:
1391 case scm_tc7_string
:
1393 case scm_tc7_byvect
:
1400 #if SCM_SIZEOF_LONG_LONG != 0
1401 case scm_tc7_llvect
:
1406 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1407 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1409 for (k
= 0; k
< ndim
; k
++)
1410 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1411 if (!SCM_UNBNDP (strict
))
1413 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1415 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1417 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1418 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1425 SCM v
= SCM_ARRAY_V (ra
);
1426 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1427 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1431 sra
= scm_make_ra (1);
1432 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1433 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1434 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1435 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1436 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1445 scm_ra2contig (SCM ra
, int copy
)
1450 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1451 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1452 k
= SCM_ARRAY_NDIM (ra
);
1453 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1455 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1457 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1458 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1459 0 == len
% SCM_LONG_BIT
))
1462 ret
= scm_make_ra (k
);
1463 SCM_ARRAY_BASE (ret
) = 0;
1466 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1467 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1468 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1469 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1471 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_prototype (ra
));
1473 scm_array_copy_x (ra
, ret
);
1479 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1480 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1481 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1482 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1483 "binary objects from @var{port-or-fdes}.\n"
1484 "If an end of file is encountered,\n"
1485 "the objects up to that point are put into @var{ura}\n"
1486 "(starting at the beginning) and the remainder of the array is\n"
1488 "The optional arguments @var{start} and @var{end} allow\n"
1489 "a specified region of a vector (or linearized array) to be read,\n"
1490 "leaving the remainder of the vector unchanged.\n\n"
1491 "@code{uniform-array-read!} returns the number of objects read.\n"
1492 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1493 "returned by @code{(current-input-port)}.")
1494 #define FUNC_NAME s_scm_uniform_array_read_x
1496 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1503 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1504 if (SCM_UNBNDP (port_or_fd
))
1505 port_or_fd
= scm_cur_inp
;
1507 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1508 || (SCM_OPINPORTP (port_or_fd
)),
1509 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1510 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1512 : SCM_INUM (scm_uniform_vector_length (v
)));
1518 badarg1
:SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1520 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1521 cra
= scm_ra2contig (ra
, 0);
1522 cstart
+= SCM_ARRAY_BASE (cra
);
1523 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1524 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1525 v
= SCM_ARRAY_V (cra
);
1527 case scm_tc7_string
:
1528 base
= SCM_STRING_CHARS (v
);
1532 base
= (char *) SCM_BITVECTOR_BASE (v
);
1533 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1534 cstart
/= SCM_LONG_BIT
;
1537 case scm_tc7_byvect
:
1538 base
= (char *) SCM_UVECTOR_BASE (v
);
1543 base
= (char *) SCM_UVECTOR_BASE (v
);
1547 base
= (char *) SCM_UVECTOR_BASE (v
);
1548 sz
= sizeof (short);
1550 #if SCM_SIZEOF_LONG_LONG != 0
1551 case scm_tc7_llvect
:
1552 base
= (char *) SCM_UVECTOR_BASE (v
);
1553 sz
= sizeof (long long);
1557 base
= (char *) SCM_UVECTOR_BASE (v
);
1558 sz
= sizeof (float);
1561 base
= (char *) SCM_UVECTOR_BASE (v
);
1562 sz
= sizeof (double);
1565 base
= (char *) SCM_UVECTOR_BASE (v
);
1566 sz
= 2 * sizeof (double);
1571 if (!SCM_UNBNDP (start
))
1574 SCM_NUM2LONG (3, start
);
1576 if (offset
< 0 || offset
>= cend
)
1577 scm_out_of_range (FUNC_NAME
, start
);
1579 if (!SCM_UNBNDP (end
))
1582 SCM_NUM2LONG (4, end
);
1584 if (tend
<= offset
|| tend
> cend
)
1585 scm_out_of_range (FUNC_NAME
, end
);
1590 if (SCM_NIMP (port_or_fd
))
1592 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1593 int remaining
= (cend
- offset
) * sz
;
1594 char *dest
= base
+ (cstart
+ offset
) * sz
;
1596 if (pt
->rw_active
== SCM_PORT_WRITE
)
1597 scm_flush (port_or_fd
);
1599 ans
= cend
- offset
;
1600 while (remaining
> 0)
1602 if (pt
->read_pos
< pt
->read_end
)
1604 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1607 memcpy (dest
, pt
->read_pos
, to_copy
);
1608 pt
->read_pos
+= to_copy
;
1609 remaining
-= to_copy
;
1614 if (scm_fill_input (port_or_fd
) == EOF
)
1616 if (remaining
% sz
!= 0)
1618 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1620 ans
-= remaining
/ sz
;
1627 pt
->rw_active
= SCM_PORT_READ
;
1629 else /* file descriptor. */
1631 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1632 base
+ (cstart
+ offset
) * sz
,
1633 (sz
* (cend
- offset
))));
1637 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1638 ans
*= SCM_LONG_BIT
;
1640 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1641 scm_array_copy_x (cra
, ra
);
1643 return SCM_MAKINUM (ans
);
1647 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1648 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1649 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1650 "Writes all elements of @var{ura} as binary objects to\n"
1651 "@var{port-or-fdes}.\n\n"
1652 "The optional arguments @var{start}\n"
1653 "and @var{end} allow\n"
1654 "a specified region of a vector (or linearized array) to be written.\n\n"
1655 "The number of objects actually written is returned.\n"
1656 "@var{port-or-fdes} may be\n"
1657 "omitted, in which case it defaults to the value returned by\n"
1658 "@code{(current-output-port)}.")
1659 #define FUNC_NAME s_scm_uniform_array_write
1667 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1669 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1670 if (SCM_UNBNDP (port_or_fd
))
1671 port_or_fd
= scm_cur_outp
;
1673 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1674 || (SCM_OPOUTPORTP (port_or_fd
)),
1675 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1676 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1678 : SCM_INUM (scm_uniform_vector_length (v
)));
1684 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1686 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1687 v
= scm_ra2contig (v
, 1);
1688 cstart
= SCM_ARRAY_BASE (v
);
1689 vlen
= (SCM_ARRAY_DIMS (v
)->inc
1690 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1));
1691 v
= SCM_ARRAY_V (v
);
1693 case scm_tc7_string
:
1694 base
= SCM_STRING_CHARS (v
);
1698 base
= (char *) SCM_BITVECTOR_BASE (v
);
1699 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1700 cstart
/= SCM_LONG_BIT
;
1703 case scm_tc7_byvect
:
1704 base
= (char *) SCM_UVECTOR_BASE (v
);
1709 base
= (char *) SCM_UVECTOR_BASE (v
);
1713 base
= (char *) SCM_UVECTOR_BASE (v
);
1714 sz
= sizeof (short);
1716 #if SCM_SIZEOF_LONG_LONG != 0
1717 case scm_tc7_llvect
:
1718 base
= (char *) SCM_UVECTOR_BASE (v
);
1719 sz
= sizeof (long long);
1723 base
= (char *) SCM_UVECTOR_BASE (v
);
1724 sz
= sizeof (float);
1727 base
= (char *) SCM_UVECTOR_BASE (v
);
1728 sz
= sizeof (double);
1731 base
= (char *) SCM_UVECTOR_BASE (v
);
1732 sz
= 2 * sizeof (double);
1737 if (!SCM_UNBNDP (start
))
1740 SCM_NUM2LONG (3, start
);
1742 if (offset
< 0 || offset
>= cend
)
1743 scm_out_of_range (FUNC_NAME
, start
);
1745 if (!SCM_UNBNDP (end
))
1748 SCM_NUM2LONG (4, end
);
1750 if (tend
<= offset
|| tend
> cend
)
1751 scm_out_of_range (FUNC_NAME
, end
);
1756 if (SCM_NIMP (port_or_fd
))
1758 char *source
= base
+ (cstart
+ offset
) * sz
;
1760 ans
= cend
- offset
;
1761 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1763 else /* file descriptor. */
1765 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1766 base
+ (cstart
+ offset
) * sz
,
1767 (sz
* (cend
- offset
))));
1771 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1772 ans
*= SCM_LONG_BIT
;
1774 return SCM_MAKINUM (ans
);
1779 static char cnt_tab
[16] =
1780 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1782 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1783 (SCM b
, SCM bitvector
),
1784 "Return the number of occurrences of the boolean @var{b} in\n"
1786 #define FUNC_NAME s_scm_bit_count
1788 SCM_VALIDATE_BOOL (1, b
);
1789 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1790 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1793 unsigned long int count
= 0;
1794 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1795 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1796 if (SCM_FALSEP (b
)) {
1799 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1802 count
+= cnt_tab
[w
& 0x0f];
1806 return SCM_MAKINUM (count
);
1809 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1810 if (SCM_FALSEP (b
)) {
1820 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1821 (SCM item
, SCM v
, SCM k
),
1822 "Return the minimum index of an occurrence of @var{bool} in\n"
1823 "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
1824 "within the specified range @code{#f} is returned.")
1825 #define FUNC_NAME s_scm_bit_position
1827 long i
, lenw
, xbits
, pos
;
1828 register unsigned long w
;
1830 SCM_VALIDATE_BOOL (1, item
);
1831 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1832 SCM_VALIDATE_INUM_COPY (3, k
, pos
);
1833 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1835 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1838 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1839 i
= pos
/ SCM_LONG_BIT
;
1840 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1841 if (SCM_FALSEP (item
))
1843 xbits
= (pos
% SCM_LONG_BIT
);
1845 w
= ((w
>> xbits
) << xbits
);
1846 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1849 if (w
&& (i
== lenw
))
1850 w
= ((w
<< xbits
) >> xbits
);
1856 return SCM_MAKINUM (pos
);
1861 return SCM_MAKINUM (pos
+ 1);
1864 return SCM_MAKINUM (pos
+ 2);
1866 return SCM_MAKINUM (pos
+ 3);
1873 pos
+= SCM_LONG_BIT
;
1874 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1875 if (SCM_FALSEP (item
))
1883 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1884 (SCM v
, SCM kv
, SCM obj
),
1885 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1886 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1887 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1888 "AND'ed into @var{bv}.\n\n"
1889 "If uve is a unsigned long integer vector all the elements of uve\n"
1890 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1891 "of @var{bv} corresponding to the indexes in uve are set to\n"
1892 "@var{bool}. The return value is unspecified.")
1893 #define FUNC_NAME s_scm_bit_set_star_x
1895 register long i
, k
, vlen
;
1896 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1897 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1898 switch SCM_TYP7 (kv
)
1901 badarg2
:SCM_WRONG_TYPE_ARG (2, kv
);
1903 vlen
= SCM_BITVECTOR_LENGTH (v
);
1904 if (SCM_FALSEP (obj
))
1905 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1907 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1909 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1910 SCM_BITVEC_CLR(v
, k
);
1912 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1913 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1915 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1917 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1918 SCM_BITVEC_SET(v
, k
);
1921 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1924 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1925 if (SCM_FALSEP (obj
))
1926 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1927 SCM_BITVECTOR_BASE (v
) [k
] &= ~SCM_BITVECTOR_BASE (kv
) [k
];
1928 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1929 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1930 SCM_BITVECTOR_BASE (v
) [k
] |= SCM_BITVECTOR_BASE (kv
) [k
];
1935 return SCM_UNSPECIFIED
;
1940 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1941 (SCM v
, SCM kv
, SCM obj
),
1944 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1946 "@var{bv} is not modified.")
1947 #define FUNC_NAME s_scm_bit_count_star
1949 register long i
, vlen
, count
= 0;
1950 register unsigned long k
;
1953 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1954 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1955 switch SCM_TYP7 (kv
)
1959 SCM_WRONG_TYPE_ARG (2, kv
);
1961 vlen
= SCM_BITVECTOR_LENGTH (v
);
1962 if (SCM_FALSEP (obj
))
1963 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1965 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1967 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1968 if (!SCM_BITVEC_REF(v
, k
))
1971 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1972 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1974 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1976 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1977 if (SCM_BITVEC_REF (v
, k
))
1981 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1984 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1985 if (0 == SCM_BITVECTOR_LENGTH (v
))
1987 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1988 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1989 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1990 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1991 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1995 count
+= cnt_tab
[k
& 0x0f];
1997 return SCM_MAKINUM (count
);
1999 /* urg. repetitive (see above.) */
2000 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
2003 return SCM_MAKINUM (count
);
2008 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2010 "Modify @var{bv} by replacing each element with its negation.")
2011 #define FUNC_NAME s_scm_bit_invert_x
2015 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
2017 k
= SCM_BITVECTOR_LENGTH (v
);
2018 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
2019 SCM_BITVECTOR_BASE (v
) [k
] = ~SCM_BITVECTOR_BASE (v
) [k
];
2021 return SCM_UNSPECIFIED
;
2027 scm_istr2bve (char *str
, long len
)
2029 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
2030 long *data
= (long *) SCM_VELTS (v
);
2031 register unsigned long mask
;
2034 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2037 j
= len
- k
* SCM_LONG_BIT
;
2038 if (j
> SCM_LONG_BIT
)
2040 for (mask
= 1L; j
--; mask
<<= 1)
2058 ra2l (SCM ra
, unsigned long base
, unsigned long k
)
2060 register SCM res
= SCM_EOL
;
2061 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2063 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2065 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2066 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2071 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2079 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2086 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2088 "Return a list consisting of all the elements, in order, of\n"
2090 #define FUNC_NAME s_scm_array_to_list
2094 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2098 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
2100 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2101 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2102 case scm_tc7_vector
:
2104 return scm_vector_to_list (v
);
2105 case scm_tc7_string
:
2106 return scm_string_to_list (v
);
2109 long *data
= (long *) SCM_VELTS (v
);
2110 register unsigned long mask
;
2111 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2112 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2113 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2114 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2115 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2118 case scm_tc7_byvect
:
2120 signed char *data
= (signed char *) SCM_VELTS (v
);
2121 unsigned long k
= SCM_UVECTOR_LENGTH (v
);
2123 res
= scm_cons (SCM_MAKINUM (data
[--k
]), res
);
2128 long *data
= (long *)SCM_VELTS(v
);
2129 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2130 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2135 long *data
= (long *)SCM_VELTS(v
);
2136 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2137 res
= scm_cons(scm_long2num(data
[k
]), res
);
2142 short *data
= (short *)SCM_VELTS(v
);
2143 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2144 res
= scm_cons(scm_short2num (data
[k
]), res
);
2147 #if SCM_SIZEOF_LONG_LONG != 0
2148 case scm_tc7_llvect
:
2150 long long *data
= (long long *)SCM_VELTS(v
);
2151 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2152 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2158 float *data
= (float *) SCM_VELTS (v
);
2159 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2160 res
= scm_cons (scm_make_real (data
[k
]), res
);
2165 double *data
= (double *) SCM_VELTS (v
);
2166 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2167 res
= scm_cons (scm_make_real (data
[k
]), res
);
2172 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2173 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2174 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2182 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2184 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2185 (SCM ndim
, SCM prot
, SCM lst
),
2186 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2187 "Return a uniform array of the type indicated by prototype\n"
2188 "@var{prot} with elements the same as those of @var{lst}.\n"
2189 "Elements must be of the appropriate type, no coercions are\n"
2191 #define FUNC_NAME s_scm_list_to_uniform_array
2198 SCM_VALIDATE_INUM_COPY (1, ndim
, k
);
2201 n
= scm_ilength (row
);
2202 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2203 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2205 row
= SCM_CAR (row
);
2207 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2209 if (SCM_NULLP (shp
))
2211 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2212 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2215 if (!SCM_ARRAYP (ra
))
2217 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2218 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2219 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2222 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2225 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2231 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2233 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2234 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2237 return (SCM_NULLP (lst
));
2238 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2242 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2244 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2246 lst
= SCM_CDR (lst
);
2248 if (SCM_NNULLP (lst
))
2255 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2257 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2259 lst
= SCM_CDR (lst
);
2261 if (SCM_NNULLP (lst
))
2269 rapr1 (SCM ra
, unsigned long j
, unsigned long k
, SCM port
, scm_print_state
*pstate
)
2272 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2274 : SCM_INUM (scm_uniform_vector_length (ra
)));
2277 switch SCM_TYP7 (ra
)
2282 SCM_ARRAY_BASE (ra
) = j
;
2284 scm_iprin1 (ra
, port
, pstate
);
2285 for (j
+= inc
; n
-- > 0; j
+= inc
)
2287 scm_putc (' ', port
);
2288 SCM_ARRAY_BASE (ra
) = j
;
2289 scm_iprin1 (ra
, port
, pstate
);
2293 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2296 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2297 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2299 scm_putc ('(', port
);
2300 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2301 scm_puts (") ", port
);
2304 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2305 { /* could be zero size. */
2306 scm_putc ('(', port
);
2307 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2308 scm_putc (')', port
);
2312 if (SCM_ARRAY_NDIM (ra
) > 0)
2313 { /* Could be zero-dimensional */
2314 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2315 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2319 ra
= SCM_ARRAY_V (ra
);
2322 /* scm_tc7_bvect and scm_tc7_llvect only? */
2324 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2325 for (j
+= inc
; n
-- > 0; j
+= inc
)
2327 scm_putc (' ', port
);
2328 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2331 case scm_tc7_string
:
2333 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2334 if (SCM_WRITINGP (pstate
))
2335 for (j
+= inc
; n
-- > 0; j
+= inc
)
2337 scm_putc (' ', port
);
2338 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2341 for (j
+= inc
; n
-- > 0; j
+= inc
)
2342 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2344 case scm_tc7_byvect
:
2346 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2347 for (j
+= inc
; n
-- > 0; j
+= inc
)
2349 scm_putc (' ', port
);
2350 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2360 /* intprint can't handle >= 2^31. */
2361 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2362 scm_puts (str
, port
);
2364 for (j
+= inc
; n
-- > 0; j
+= inc
)
2366 scm_putc (' ', port
);
2367 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2368 scm_puts (str
, port
);
2373 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2374 for (j
+= inc
; n
-- > 0; j
+= inc
)
2376 scm_putc (' ', port
);
2377 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2383 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2384 for (j
+= inc
; n
-- > 0; j
+= inc
)
2386 scm_putc (' ', port
);
2387 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2394 SCM z
= scm_make_real (1.0);
2395 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2396 scm_print_real (z
, port
, pstate
);
2397 for (j
+= inc
; n
-- > 0; j
+= inc
)
2399 scm_putc (' ', port
);
2400 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2401 scm_print_real (z
, port
, pstate
);
2408 SCM z
= scm_make_real (1.0 / 3.0);
2409 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2410 scm_print_real (z
, port
, pstate
);
2411 for (j
+= inc
; n
-- > 0; j
+= inc
)
2413 scm_putc (' ', port
);
2414 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2415 scm_print_real (z
, port
, pstate
);
2422 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2423 SCM_REAL_VALUE (z
) =
2424 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2425 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2426 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2428 for (j
+= inc
; n
-- > 0; j
+= inc
)
2430 scm_putc (' ', port
);
2432 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2433 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2434 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2445 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2448 unsigned long base
= 0;
2449 scm_putc ('#', port
);
2455 long ndim
= SCM_ARRAY_NDIM (v
);
2456 base
= SCM_ARRAY_BASE (v
);
2457 v
= SCM_ARRAY_V (v
);
2461 scm_puts ("<enclosed-array ", port
);
2462 rapr1 (exp
, base
, 0, port
, pstate
);
2463 scm_putc ('>', port
);
2468 scm_intprint (ndim
, 10, port
);
2473 if (SCM_EQ_P (exp
, v
))
2474 { /* a uve, not an scm_array */
2475 register long i
, j
, w
;
2476 scm_putc ('*', port
);
2477 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2479 scm_t_bits w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2480 for (j
= SCM_LONG_BIT
; j
; j
--)
2482 scm_putc (w
& 1 ? '1' : '0', port
);
2486 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2489 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2492 scm_putc (w
& 1 ? '1' : '0', port
);
2499 scm_putc ('b', port
);
2501 case scm_tc7_string
:
2502 scm_putc ('a', port
);
2504 case scm_tc7_byvect
:
2505 scm_putc ('y', port
);
2508 scm_putc ('u', port
);
2511 scm_putc ('e', port
);
2514 scm_putc ('h', port
);
2516 #if SCM_SIZEOF_LONG_LONG != 0
2517 case scm_tc7_llvect
:
2518 scm_putc ('l', port
);
2522 scm_putc ('s', port
);
2525 scm_putc ('i', port
);
2528 scm_putc ('c', port
);
2531 scm_putc ('(', port
);
2532 rapr1 (exp
, base
, 0, port
, pstate
);
2533 scm_putc (')', port
);
2537 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2539 "Return an object that would produce an array of the same type\n"
2540 "as @var{array}, if used as the @var{prototype} for\n"
2541 "@code{make-uniform-array}.")
2542 #define FUNC_NAME s_scm_array_prototype
2545 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2547 switch SCM_TYP7 (ra
)
2550 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
2552 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2554 return SCM_UNSPECIFIED
;
2555 ra
= SCM_ARRAY_V (ra
);
2557 case scm_tc7_vector
:
2562 case scm_tc7_string
:
2563 return SCM_MAKE_CHAR ('a');
2564 case scm_tc7_byvect
:
2565 return SCM_MAKE_CHAR ('\0');
2567 return SCM_MAKINUM (1L);
2569 return SCM_MAKINUM (-1L);
2571 return scm_str2symbol ("s");
2572 #if SCM_SIZEOF_LONG_LONG != 0
2573 case scm_tc7_llvect
:
2574 return scm_str2symbol ("l");
2577 return scm_make_real (1.0);
2579 return scm_make_real (1.0 / 3.0);
2581 return scm_make_complex (0.0, 1.0);
2588 array_mark (SCM ptr
)
2590 return SCM_ARRAY_V (ptr
);
2595 array_free (SCM ptr
)
2597 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2598 (sizeof (scm_t_array
)
2599 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2607 scm_tc16_array
= scm_make_smob_type ("array", 0);
2608 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2609 scm_set_smob_free (scm_tc16_array
, array_free
);
2610 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2611 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2612 scm_add_feature ("array");
2613 #include "libguile/unif.x"