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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
46 This file has code for arrays in lots of variants (double, integer,
47 unsigned etc. ). It suffers from hugely repetitive code because
48 there is similar (but different) code for every variant included. (urg.)
55 #include "libguile/_scm.h"
56 #include "libguile/chars.h"
57 #include "libguile/eval.h"
58 #include "libguile/fports.h"
59 #include "libguile/smob.h"
60 #include "libguile/strop.h"
61 #include "libguile/feature.h"
62 #include "libguile/root.h"
63 #include "libguile/strings.h"
64 #include "libguile/vectors.h"
66 #include "libguile/validate.h"
67 #include "libguile/unif.h"
68 #include "libguile/ramap.h"
75 /* The set of uniform scm_vector types is:
77 * unsigned char string
84 * complex double cvect
89 scm_bits_t scm_tc16_array
;
91 /* return the size of an element in a uniform array or 0 if type not
94 scm_uniform_element_size (SCM obj
)
98 switch (SCM_TYP7 (obj
))
103 result
= sizeof (long);
107 result
= sizeof (char);
111 result
= sizeof (short);
114 #ifdef HAVE_LONG_LONGS
116 result
= sizeof (long_long
);
121 result
= sizeof (float);
125 result
= sizeof (double);
129 result
= 2 * sizeof (double);
138 /* Silly function used not to modify the semantics of the silly
139 * prototype system in order to be backward compatible.
144 if (!SCM_SLOPPY_REALP (obj
))
148 double x
= SCM_REAL_VALUE (obj
);
150 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
155 scm_make_uve (long k
, SCM prot
)
156 #define FUNC_NAME "scm_make_uve"
161 if (SCM_EQ_P (prot
, SCM_BOOL_T
))
166 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_BITVECTOR_MAX_LENGTH
);
167 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
168 SCM_SET_BITVECTOR_BASE (v
, (char *) scm_must_malloc (i
, "vector"));
169 SCM_SET_BITVECTOR_LENGTH (v
, k
);
173 SCM_SET_BITVECTOR_BASE (v
, 0);
174 SCM_SET_BITVECTOR_LENGTH (v
, 0);
178 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
180 i
= sizeof (char) * k
;
181 type
= scm_tc7_byvect
;
183 else if (SCM_CHARP (prot
))
185 i
= sizeof (char) * k
;
186 return scm_makstr (i
, 0);
188 else if (SCM_INUMP (prot
))
190 i
= sizeof (long) * k
;
191 if (SCM_INUM (prot
) > 0)
192 type
= scm_tc7_uvect
;
194 type
= scm_tc7_ivect
;
196 else if (SCM_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
200 s
= SCM_SYMBOL_CHARS (prot
)[0];
203 i
= sizeof (short) * k
;
204 type
= scm_tc7_svect
;
206 #ifdef HAVE_LONG_LONGS
209 i
= sizeof (long_long
) * k
;
210 type
= scm_tc7_llvect
;
215 return scm_c_make_vector (k
, SCM_UNDEFINED
);
218 else if (!SCM_INEXACTP (prot
))
219 /* Huge non-unif vectors are NOT supported. */
220 /* no special scm_vector */
221 return scm_c_make_vector (k
, SCM_UNDEFINED
);
222 else if (singp (prot
))
224 i
= sizeof (float) * k
;
225 type
= scm_tc7_fvect
;
227 else if (SCM_COMPLEXP (prot
))
229 i
= 2 * sizeof (double) * k
;
230 type
= scm_tc7_cvect
;
234 i
= sizeof (double) * k
;
235 type
= scm_tc7_dvect
;
238 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_UVECTOR_MAX_LENGTH
);
242 SCM_SET_UVECTOR_BASE (v
, (char *) scm_must_malloc (i
? i
: 1, "vector"));
243 SCM_SET_UVECTOR_LENGTH (v
, k
, type
);
250 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
252 "Returns the number of elements in @var{uve}.")
253 #define FUNC_NAME s_scm_uniform_vector_length
255 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
259 badarg1
:SCM_WTA(1,v
);
262 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v
));
264 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
266 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
274 #ifdef HAVE_LONG_LONGS
277 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v
));
282 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
284 "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n"
285 "The @var{prototype} argument is used with uniform arrays and is described\n"
287 #define FUNC_NAME s_scm_array_p
291 nprot
= SCM_UNBNDP (prot
);
296 while (SCM_TYP7 (v
) == scm_tc7_smob
)
307 return SCM_BOOL(nprot
);
312 switch (SCM_TYP7 (v
))
315 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
317 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
319 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
321 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
323 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
326 protp
= SCM_SYMBOLP (prot
)
327 && (1 == SCM_SYMBOL_LENGTH (prot
))
328 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
329 #ifdef HAVE_LONG_LONGS
331 protp
= SCM_SYMBOLP (prot
)
332 && (1 == SCM_SYMBOL_LENGTH (prot
))
333 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
336 protp
= singp (prot
);
338 protp
= SCM_REALP(prot
);
340 protp
= SCM_COMPLEXP(prot
);
343 protp
= SCM_NULLP(prot
);
348 return SCM_BOOL(protp
);
354 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
356 "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n"
357 "array, @code{0} is returned.")
358 #define FUNC_NAME s_scm_array_rank
362 switch (SCM_TYP7 (ra
))
375 #ifdef HAVE_LONG_LONGS
379 return SCM_MAKINUM (1L);
382 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
389 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
391 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
392 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
394 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
396 #define FUNC_NAME s_scm_array_dimensions
403 switch (SCM_TYP7 (ra
))
418 #ifdef HAVE_LONG_LONGS
421 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
423 if (!SCM_ARRAYP (ra
))
425 k
= SCM_ARRAY_NDIM (ra
);
426 s
= SCM_ARRAY_DIMS (ra
);
428 res
= scm_cons (s
[k
].lbnd
429 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
430 SCM_MAKINUM (s
[k
].ubnd
),
432 : SCM_MAKINUM (1 + s
[k
].ubnd
),
440 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
442 "Return the root vector of a shared array.")
443 #define FUNC_NAME s_scm_shared_array_root
445 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
446 return SCM_ARRAY_V (ra
);
451 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
453 "Return the root vector index of the first element in the array.")
454 #define FUNC_NAME s_scm_shared_array_offset
456 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
457 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
462 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
464 "For each dimension, return the distance between elements in the root vector.")
465 #define FUNC_NAME s_scm_shared_array_increments
470 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
471 k
= SCM_ARRAY_NDIM (ra
);
472 s
= SCM_ARRAY_DIMS (ra
);
474 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
480 static char s_bad_ind
[] = "Bad scm_array index";
484 scm_aind (SCM ra
, SCM args
, const char *what
)
488 register scm_sizet pos
= SCM_ARRAY_BASE (ra
);
489 register scm_sizet k
= SCM_ARRAY_NDIM (ra
);
490 scm_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
491 if (SCM_INUMP (args
))
493 SCM_ASSERT (1 == k
, scm_makfrom0str (what
), SCM_WNA
, NULL
);
494 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
496 while (k
&& SCM_NIMP (args
))
498 ind
= SCM_CAR (args
);
499 args
= SCM_CDR (args
);
500 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, what
);
502 if (j
< s
->lbnd
|| j
> s
->ubnd
)
503 scm_out_of_range (what
, ind
);
504 pos
+= (j
- s
->lbnd
) * (s
->inc
);
508 SCM_ASSERT (0 == k
&& SCM_NULLP (args
), scm_makfrom0str (what
), SCM_WNA
,
516 scm_make_ra (int ndim
)
521 SCM_NEWSMOB(ra
, ((long) ndim
<< 17) + scm_tc16_array
,
522 scm_must_malloc ((long) (sizeof (scm_array
) + ndim
* sizeof (scm_array_dim
)),
524 SCM_ARRAY_V (ra
) = scm_nullvect
;
529 static char s_bad_spec
[] = "Bad scm_array dimension";
530 /* Increments will still need to be set. */
534 scm_shap2ra (SCM args
, const char *what
)
538 int ndim
= scm_ilength (args
);
539 SCM_ASSERT (0 <= ndim
, args
, s_bad_spec
, what
);
540 ra
= scm_make_ra (ndim
);
541 SCM_ARRAY_BASE (ra
) = 0;
542 s
= SCM_ARRAY_DIMS (ra
);
543 for (; !SCM_NULLP (args
); s
++, args
= SCM_CDR (args
))
545 spec
= SCM_CAR (args
);
546 if (SCM_INUMP (spec
))
548 SCM_ASSERT (SCM_INUM (spec
) >= 0, spec
, s_bad_spec
, what
);
550 s
->ubnd
= SCM_INUM (spec
) - 1;
555 SCM_ASSERT (SCM_CONSP (spec
) && SCM_INUMP (SCM_CAR (spec
)), spec
,
557 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
559 SCM_ASSERT (SCM_CONSP (sp
)
560 && SCM_INUMP (SCM_CAR (sp
)) && SCM_NULLP (SCM_CDR (sp
)),
561 spec
, s_bad_spec
, what
);
562 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
569 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
570 (SCM dims
, SCM prot
, SCM fill
),
571 "@deffnx primitive make-uniform-vector length prototype [fill]\n"
572 "Creates and returns a uniform array or vector of type corresponding to\n"
573 "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n"
574 "@var{fill} is supplied, it's used to fill the array, otherwise \n"
575 "@var{prototype} is used.")
576 #define FUNC_NAME s_scm_dimensions_to_uniform_array
579 unsigned long int rlen
= 1;
582 if (SCM_INUMP (dims
))
584 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
585 if (!SCM_UNBNDP (fill
))
586 scm_array_fill_x (answer
, fill
);
587 else if (SCM_SYMBOLP (prot
))
588 scm_array_fill_x (answer
, SCM_MAKINUM (0));
590 scm_array_fill_x (answer
, prot
);
593 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
594 dims
, SCM_ARG1
, FUNC_NAME
);
595 ra
= scm_shap2ra (dims
, FUNC_NAME
);
596 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
597 s
= SCM_ARRAY_DIMS (ra
);
598 k
= SCM_ARRAY_NDIM (ra
);
602 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
603 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
606 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
608 if (!SCM_UNBNDP (fill
))
609 scm_array_fill_x (ra
, fill
);
610 else if (SCM_SYMBOLP (prot
))
611 scm_array_fill_x (ra
, SCM_MAKINUM (0));
613 scm_array_fill_x (ra
, prot
);
615 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
616 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
617 return SCM_ARRAY_V (ra
);
624 scm_ra_set_contp (SCM ra
)
626 scm_sizet k
= SCM_ARRAY_NDIM (ra
);
629 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
632 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
634 SCM_SETAND_CAR (ra
, ~SCM_ARRAY_CONTIGUOUS
);
637 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
638 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
641 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
645 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
646 (SCM oldra
, SCM mapfunc
, SCM dims
),
647 "@code{make-shared-array} can be used to create shared subarrays of other\n"
648 "arrays. The @var{mapper} is a function that translates coordinates in\n"
649 "the new array into coordinates in the old array. A @var{mapper} must be\n"
650 "linear, and its range must stay within the bounds of the old array, but\n"
651 "it can be otherwise arbitrary. A simple example:\n"
653 "(define fred (make-array #f 8 8))\n"
654 "(define freds-diagonal\n"
655 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
656 "(array-set! freds-diagonal 'foo 3)\n"
657 "(array-ref fred 3 3) @result{} foo\n"
658 "(define freds-center\n"
659 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
660 "(array-ref freds-center 0 0) @result{} foo\n"
662 #define FUNC_NAME s_scm_make_shared_array
668 long old_min
, new_min
, old_max
, new_max
;
670 SCM_VALIDATE_ARRAY (1,oldra
);
671 SCM_VALIDATE_PROC (2,mapfunc
);
672 ra
= scm_shap2ra (dims
, FUNC_NAME
);
673 if (SCM_ARRAYP (oldra
))
675 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
676 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
677 s
= SCM_ARRAY_DIMS (oldra
);
678 k
= SCM_ARRAY_NDIM (oldra
);
682 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
684 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
689 SCM_ARRAY_V (ra
) = oldra
;
691 old_max
= SCM_INUM (scm_uniform_vector_length (oldra
)) - 1;
694 s
= SCM_ARRAY_DIMS (ra
);
695 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
697 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
698 if (s
[k
].ubnd
< s
[k
].lbnd
)
700 if (1 == SCM_ARRAY_NDIM (ra
))
701 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
703 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
707 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
708 if (SCM_ARRAYP (oldra
))
709 i
= (scm_sizet
) scm_aind (oldra
, imap
, FUNC_NAME
);
712 if (SCM_NINUMP (imap
))
715 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
716 imap
, s_bad_ind
, FUNC_NAME
);
717 imap
= SCM_CAR (imap
);
721 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
723 k
= SCM_ARRAY_NDIM (ra
);
726 if (s
[k
].ubnd
> s
[k
].lbnd
)
728 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
729 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
730 if (SCM_ARRAYP (oldra
))
732 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
735 if (SCM_NINUMP (imap
))
738 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
739 imap
, s_bad_ind
, FUNC_NAME
);
740 imap
= SCM_CAR (imap
);
742 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
746 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
748 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
751 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
752 indptr
= SCM_CDR (indptr
);
754 SCM_ASSERT (old_min
<= new_min
&& old_max
>= new_max
, SCM_UNDEFINED
,
755 "mapping out of range", FUNC_NAME
);
756 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
758 SCM v
= SCM_ARRAY_V (ra
);
759 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
760 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
762 if (s
->ubnd
< s
->lbnd
)
763 return scm_make_uve (0L, scm_array_prototype (ra
));
765 scm_ra_set_contp (ra
);
771 /* args are RA . DIMS */
772 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
774 "Returns an array sharing contents with @var{array}, but with dimensions\n"
775 "arranged in a different order. There must be one @var{dim} argument for\n"
776 "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n"
777 "be integers between 0 and the rank of the array to be returned. Each\n"
778 "integer in that range must appear at least once in the argument list.\n\n"
779 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n"
780 "in the array to be returned, their positions in the argument list to\n"
781 "dimensions of @var{array}. Several @var{dim}s may have the same value,\n"
782 "in which case the returned array will have smaller rank than\n"
786 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
787 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
788 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
789 " #2((a 4) (b 5) (c 6))\n"
791 #define FUNC_NAME s_scm_transpose_array
793 SCM res
, vargs
, *ve
= &vargs
;
794 scm_array_dim
*s
, *r
;
797 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
798 switch (SCM_TYP7 (ra
))
801 badarg
:SCM_WTA (1,ra
);
811 #ifdef HAVE_LONG_LONGS
814 SCM_ASSERT (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
815 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
816 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), SCM_CAR (args
), SCM_ARG2
,
818 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
819 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
822 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
823 vargs
= scm_vector (args
);
824 SCM_ASSERT (SCM_VECTOR_LENGTH (vargs
) == SCM_ARRAY_NDIM (ra
),
825 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
826 ve
= SCM_VELTS (vargs
);
828 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
830 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
832 i
= SCM_INUM (ve
[k
]);
833 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
834 scm_out_of_range (FUNC_NAME
, ve
[k
]);
839 res
= scm_make_ra (ndim
);
840 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
841 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
844 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
845 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
847 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
849 i
= SCM_INUM (ve
[k
]);
850 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
851 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
852 if (r
->ubnd
< r
->lbnd
)
861 if (r
->ubnd
> s
->ubnd
)
863 if (r
->lbnd
< s
->lbnd
)
865 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
871 SCM_ASSERT (ndim
<= 0, args
, "bad argument list", FUNC_NAME
);
872 scm_ra_set_contp (res
);
878 /* args are RA . AXES */
879 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
881 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
882 "the rank of @var{array}. @var{enclose-array} returns an array\n"
883 "resembling an array of shared arrays. The dimensions of each shared\n"
884 "array are the same as the @var{dim}th dimensions of the original array,\n"
885 "the dimensions of the outer array are the same as those of the original\n"
886 "array that did not match a @var{dim}.\n\n"
887 "An enclosed array is not a general Scheme array. Its elements may not\n"
888 "be set using @code{array-set!}. Two references to the same element of\n"
889 "an enclosed array will be @code{equal?} but will not in general be\n"
890 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
891 "enclosed array is unspecified.\n\n"
894 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
895 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
896 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
897 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
899 #define FUNC_NAME s_scm_enclose_array
901 SCM axv
, res
, ra_inr
;
902 scm_array_dim vdim
, *s
= &vdim
;
903 int ndim
, j
, k
, ninr
, noutr
;
905 if (SCM_NULLP (axes
))
906 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
907 ninr
= scm_ilength (axes
);
908 SCM_ASSERT (0 <= ninr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
909 ra_inr
= scm_make_ra (ninr
);
910 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
914 badarg1
:SCM_WTA (1,ra
);
926 #ifdef HAVE_LONG_LONGS
930 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
932 SCM_ARRAY_V (ra_inr
) = ra
;
933 SCM_ARRAY_BASE (ra_inr
) = 0;
937 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
938 s
= SCM_ARRAY_DIMS (ra
);
939 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
940 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
941 ndim
= SCM_ARRAY_NDIM (ra
);
945 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
946 SCM_ASSERT (0 <= noutr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
947 res
= scm_make_ra (noutr
);
948 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
949 SCM_ARRAY_V (res
) = ra_inr
;
950 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
952 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes
)), SCM_CAR (axes
), "bad axis", FUNC_NAME
);
953 j
= SCM_INUM (SCM_CAR (axes
));
954 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
955 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
956 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
957 SCM_STRING_CHARS (axv
)[j
] = 1;
959 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
961 while (SCM_STRING_CHARS (axv
)[j
])
963 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
964 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
965 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
967 scm_ra_set_contp (ra_inr
);
968 scm_ra_set_contp (res
);
975 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
977 "Returns @code{#t} if its arguments would be acceptable to array-ref.")
978 #define FUNC_NAME s_scm_array_in_bounds_p
982 register scm_sizet k
;
986 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
990 ind
= SCM_CAR (args
);
991 args
= SCM_CDR (args
);
992 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
993 pos
= SCM_INUM (ind
);
999 badarg1
:SCM_WTA (1,v
);
1000 wna
: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME
));
1002 k
= SCM_ARRAY_NDIM (v
);
1003 s
= SCM_ARRAY_DIMS (v
);
1004 pos
= SCM_ARRAY_BASE (v
);
1007 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1014 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1016 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1019 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1020 if (!(--k
&& SCM_NIMP (args
)))
1022 ind
= SCM_CAR (args
);
1023 args
= SCM_CDR (args
);
1025 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, FUNC_NAME
);
1027 SCM_ASRTGO (0 == k
, wna
);
1028 v
= SCM_ARRAY_V (v
);
1031 case scm_tc7_string
:
1032 case scm_tc7_byvect
:
1039 #ifdef HAVE_LONG_LONGS
1040 case scm_tc7_llvect
:
1042 case scm_tc7_vector
:
1045 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1046 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1047 return SCM_BOOL(pos
>= 0 && pos
< length
);
1054 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1057 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1059 "@deffnx primitive array-ref v . args\n"
1060 "Returns the element at the @code{(index1, index2)} element in @var{array}.")
1061 #define FUNC_NAME s_scm_uniform_vector_ref
1067 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1070 else if (SCM_ARRAYP (v
))
1072 pos
= scm_aind (v
, args
, FUNC_NAME
);
1073 v
= SCM_ARRAY_V (v
);
1077 unsigned long int length
;
1078 if (SCM_NIMP (args
))
1080 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1081 pos
= SCM_INUM (SCM_CAR (args
));
1082 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1086 SCM_VALIDATE_INUM (2,args
);
1087 pos
= SCM_INUM (args
);
1089 length
= SCM_INUM (scm_uniform_vector_length (v
));
1090 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1095 if (SCM_NULLP (args
))
1102 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1104 scm_wrong_num_args (SCM_FUNC_NAME
);
1107 int k
= SCM_ARRAY_NDIM (v
);
1108 SCM res
= scm_make_ra (k
);
1109 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1110 SCM_ARRAY_BASE (res
) = pos
;
1113 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1114 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1115 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1120 if (SCM_BITVEC_REF (v
, pos
))
1124 case scm_tc7_string
:
1125 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1126 case scm_tc7_byvect
:
1127 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1129 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1131 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1134 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1135 #ifdef HAVE_LONG_LONGS
1136 case scm_tc7_llvect
:
1137 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1141 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1143 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1145 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1146 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1147 case scm_tc7_vector
:
1149 return SCM_VELTS (v
)[pos
];
1154 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1155 tries to recycle conses. (Make *sure* you want them recycled.) */
1158 scm_cvref (SCM v
, scm_sizet pos
, SCM last
)
1163 scm_wta (v
, (char *) SCM_ARG1
, "PROGRAMMING ERROR: scm_cvref");
1165 if (SCM_BITVEC_REF(v
,pos
))
1169 case scm_tc7_string
:
1170 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1171 case scm_tc7_byvect
:
1172 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1174 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1176 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1178 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1179 #ifdef HAVE_LONG_LONGS
1180 case scm_tc7_llvect
:
1181 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1184 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1186 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1189 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1191 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1193 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1196 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1198 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1200 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1201 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1204 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1205 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1206 case scm_tc7_vector
:
1208 return SCM_VELTS (v
)[pos
];
1210 { /* enclosed scm_array */
1211 int k
= SCM_ARRAY_NDIM (v
);
1212 SCM res
= scm_make_ra (k
);
1213 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1214 SCM_ARRAY_BASE (res
) = pos
;
1217 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1218 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1219 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1226 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1229 /* Note that args may be a list or an immediate object, depending which
1230 PROC is used (and it's called from C too). */
1231 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1232 (SCM v
, SCM obj
, SCM args
),
1233 "@deffnx primitive uniform-array-set1! v obj args\n"
1234 "Sets the element at the @code{(index1, index2)} element in @var{array} to\n"
1235 "@var{new-value}. The value returned by array-set! is unspecified.")
1236 #define FUNC_NAME s_scm_array_set_x
1239 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1242 pos
= scm_aind (v
, args
, FUNC_NAME
);
1243 v
= SCM_ARRAY_V (v
);
1247 unsigned long int length
;
1248 if (SCM_NIMP (args
))
1250 SCM_ASSERT (SCM_CONSP(args
) && SCM_INUMP (SCM_CAR (args
)), args
,
1251 SCM_ARG3
, FUNC_NAME
);
1252 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1253 pos
= SCM_INUM (SCM_CAR (args
));
1257 SCM_VALIDATE_INUM_COPY (3,args
,pos
);
1259 length
= SCM_INUM (scm_uniform_vector_length (v
));
1260 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1262 switch (SCM_TYP7 (v
))
1268 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1270 scm_wrong_num_args (SCM_FUNC_NAME
);
1271 case scm_tc7_smob
: /* enclosed */
1274 if (SCM_FALSEP (obj
))
1275 SCM_BITVEC_CLR(v
,pos
);
1276 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1277 SCM_BITVEC_SET(v
,pos
);
1279 badobj
:SCM_WTA (2,obj
);
1281 case scm_tc7_string
:
1282 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1283 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1285 case scm_tc7_byvect
:
1286 if (SCM_CHARP (obj
))
1287 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1288 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1289 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1292 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2ulong(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1295 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2long(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1298 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1299 ((short *) SCM_CELL_WORD_1 (v
))[pos
] = SCM_INUM (obj
);
1301 #ifdef HAVE_LONG_LONGS
1302 case scm_tc7_llvect
:
1303 ((long_long
*) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2long_long (obj
, (char *)SCM_ARG2
, FUNC_NAME
);
1309 ((float *) SCM_CELL_WORD_1 (v
))[pos
] = (float) scm_num2dbl (obj
, FUNC_NAME
);
1312 ((double *) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2dbl (obj
, FUNC_NAME
);
1315 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1316 if (SCM_REALP (obj
)) {
1317 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1318 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = 0.0;
1320 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1321 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1324 case scm_tc7_vector
:
1326 SCM_VELTS (v
)[pos
] = obj
;
1329 return SCM_UNSPECIFIED
;
1333 /* attempts to unroll an array into a one-dimensional array.
1334 returns the unrolled array or #f if it can't be done. */
1335 /* if strict is not SCM_UNDEFINED, return #f if returned array
1336 wouldn't have contiguous elements. */
1337 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1338 (SCM ra
, SCM strict
),
1339 "@deffnx primitive array-contents array strict\n"
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 #ifdef HAVE_LONG_LONGS
1370 case scm_tc7_llvect
:
1375 scm_sizet 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
)
1418 scm_sizet k
, len
= 1;
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
- 1), 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 primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1451 "Attempts 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 during\n"
1454 "uniform-array-read! the objects up to that point only 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_INUM (scm_uniform_vector_length (v
));
1485 badarg1
:SCM_WTA (SCM_ARG1
,v
);
1487 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1488 cra
= scm_ra2contig (ra
, 0);
1489 cstart
+= SCM_ARRAY_BASE (cra
);
1490 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1491 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1492 v
= SCM_ARRAY_V (cra
);
1494 case scm_tc7_string
:
1495 base
= SCM_STRING_CHARS (v
);
1499 base
= (char *) SCM_BITVECTOR_BASE (v
);
1500 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1501 cstart
/= SCM_LONG_BIT
;
1504 case scm_tc7_byvect
:
1505 base
= (char *) SCM_UVECTOR_BASE (v
);
1510 base
= (char *) SCM_UVECTOR_BASE (v
);
1514 base
= (char *) SCM_UVECTOR_BASE (v
);
1515 sz
= sizeof (short);
1517 #ifdef HAVE_LONG_LONGS
1518 case scm_tc7_llvect
:
1519 base
= (char *) SCM_UVECTOR_BASE (v
);
1520 sz
= sizeof (long_long
);
1524 base
= (char *) SCM_UVECTOR_BASE (v
);
1525 sz
= sizeof (float);
1528 base
= (char *) SCM_UVECTOR_BASE (v
);
1529 sz
= sizeof (double);
1532 base
= (char *) SCM_UVECTOR_BASE (v
);
1533 sz
= 2 * sizeof (double);
1538 if (!SCM_UNBNDP (start
))
1541 SCM_NUM2LONG (3, start
);
1543 if (offset
< 0 || offset
>= cend
)
1544 scm_out_of_range (FUNC_NAME
, start
);
1546 if (!SCM_UNBNDP (end
))
1549 SCM_NUM2LONG (4, end
);
1551 if (tend
<= offset
|| tend
> cend
)
1552 scm_out_of_range (FUNC_NAME
, end
);
1557 if (SCM_NIMP (port_or_fd
))
1559 scm_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1560 int remaining
= (cend
- offset
) * sz
;
1561 char *dest
= base
+ (cstart
+ offset
) * sz
;
1563 if (pt
->rw_active
== SCM_PORT_WRITE
)
1564 scm_flush (port_or_fd
);
1566 ans
= cend
- offset
;
1567 while (remaining
> 0)
1569 if (pt
->read_pos
< pt
->read_end
)
1571 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1574 memcpy (dest
, pt
->read_pos
, to_copy
);
1575 pt
->read_pos
+= to_copy
;
1576 remaining
-= to_copy
;
1581 if (scm_fill_input (port_or_fd
) == EOF
)
1583 if (remaining
% sz
!= 0)
1585 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1587 ans
-= remaining
/ sz
;
1594 pt
->rw_active
= SCM_PORT_READ
;
1596 else /* file descriptor. */
1598 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1599 base
+ (cstart
+ offset
) * sz
,
1600 (scm_sizet
) (sz
* (cend
- offset
))));
1604 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1605 ans
*= SCM_LONG_BIT
;
1607 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1608 scm_array_copy_x (cra
, ra
);
1610 return SCM_MAKINUM (ans
);
1614 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1615 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1616 "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1617 "Writes all elements of @var{ura} as binary objects to\n"
1618 "@var{port-or-fdes}.\n\n"
1619 "The optional arguments @var{start}\n"
1620 "and @var{end} allow\n"
1621 "a specified region of a vector (or linearized array) to be written.\n\n"
1622 "The number of objects actually written is returned. \n"
1623 "@var{port-or-fdes} may be\n"
1624 "omitted, in which case it defaults to the value returned by\n"
1625 "@code{(current-output-port)}.")
1626 #define FUNC_NAME s_scm_uniform_array_write
1634 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1636 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1637 if (SCM_UNBNDP (port_or_fd
))
1638 port_or_fd
= scm_cur_outp
;
1640 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1641 || (SCM_OPOUTPORTP (port_or_fd
)),
1642 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1643 vlen
= SCM_INUM (scm_uniform_vector_length (v
));
1649 badarg1
:SCM_WTA (1, v
);
1651 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1652 v
= scm_ra2contig (v
, 1);
1653 cstart
= SCM_ARRAY_BASE (v
);
1654 vlen
= SCM_ARRAY_DIMS (v
)->inc
1655 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1656 v
= SCM_ARRAY_V (v
);
1658 case scm_tc7_string
:
1659 base
= SCM_STRING_CHARS (v
);
1663 base
= (char *) SCM_BITVECTOR_BASE (v
);
1664 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1665 cstart
/= SCM_LONG_BIT
;
1668 case scm_tc7_byvect
:
1669 base
= (char *) SCM_UVECTOR_BASE (v
);
1674 base
= (char *) SCM_UVECTOR_BASE (v
);
1678 base
= (char *) SCM_UVECTOR_BASE (v
);
1679 sz
= sizeof (short);
1681 #ifdef HAVE_LONG_LONGS
1682 case scm_tc7_llvect
:
1683 base
= (char *) SCM_UVECTOR_BASE (v
);
1684 sz
= sizeof (long_long
);
1688 base
= (char *) SCM_UVECTOR_BASE (v
);
1689 sz
= sizeof (float);
1692 base
= (char *) SCM_UVECTOR_BASE (v
);
1693 sz
= sizeof (double);
1696 base
= (char *) SCM_UVECTOR_BASE (v
);
1697 sz
= 2 * sizeof (double);
1702 if (!SCM_UNBNDP (start
))
1705 SCM_NUM2LONG (3, start
);
1707 if (offset
< 0 || offset
>= cend
)
1708 scm_out_of_range (FUNC_NAME
, start
);
1710 if (!SCM_UNBNDP (end
))
1713 SCM_NUM2LONG (4, end
);
1715 if (tend
<= offset
|| tend
> cend
)
1716 scm_out_of_range (FUNC_NAME
, end
);
1721 if (SCM_NIMP (port_or_fd
))
1723 char *source
= base
+ (cstart
+ offset
) * sz
;
1725 ans
= cend
- offset
;
1726 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1728 else /* file descriptor. */
1730 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1731 base
+ (cstart
+ offset
) * sz
,
1732 (scm_sizet
) (sz
* (cend
- offset
))));
1736 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1737 ans
*= SCM_LONG_BIT
;
1739 return SCM_MAKINUM (ans
);
1744 static char cnt_tab
[16] =
1745 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1747 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1748 (SCM b
, SCM bitvector
),
1749 "Returns the number of occurrences of the boolean @var{b} in\n"
1751 #define FUNC_NAME s_scm_bit_count
1753 SCM_VALIDATE_BOOL (1, b
);
1754 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1755 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1758 unsigned long int count
= 0;
1759 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1760 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1761 if (SCM_FALSEP (b
)) {
1764 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1767 count
+= cnt_tab
[w
& 0x0f];
1771 return SCM_MAKINUM (count
);
1774 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1775 if (SCM_FALSEP (b
)) {
1785 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1786 (SCM item
, SCM v
, SCM k
),
1787 "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n"
1788 "which is at least @var{k}. If no @var{bool} occurs within the specified\n"
1789 "range @code{#f} is returned.")
1790 #define FUNC_NAME s_scm_bit_position
1792 long i
, lenw
, xbits
, pos
;
1793 register unsigned long w
;
1795 SCM_VALIDATE_BOOL (1, item
);
1796 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1797 SCM_VALIDATE_INUM_COPY (3,k
,pos
);
1798 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1800 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1803 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1804 i
= pos
/ SCM_LONG_BIT
;
1805 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1806 if (SCM_FALSEP (item
))
1808 xbits
= (pos
% SCM_LONG_BIT
);
1810 w
= ((w
>> xbits
) << xbits
);
1811 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1814 if (w
&& (i
== lenw
))
1815 w
= ((w
<< xbits
) >> xbits
);
1821 return SCM_MAKINUM (pos
);
1826 return SCM_MAKINUM (pos
+ 1);
1829 return SCM_MAKINUM (pos
+ 2);
1831 return SCM_MAKINUM (pos
+ 3);
1838 pos
+= SCM_LONG_BIT
;
1839 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1840 if (SCM_FALSEP (item
))
1848 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1849 (SCM v
, SCM kv
, SCM obj
),
1850 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1851 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1852 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1853 "AND'ed into @var{bv}.\n\n"
1854 "If uve is a unsigned integer vector all the elements of uve\n"
1855 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1856 "of @var{bv} corresponding to the indexes in uve are set to\n"
1857 "@var{bool}. The return value is unspecified.")
1858 #define FUNC_NAME s_scm_bit_set_star_x
1860 register long i
, k
, vlen
;
1861 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1862 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1863 switch SCM_TYP7 (kv
)
1866 badarg2
:SCM_WTA (2,kv
);
1868 vlen
= SCM_BITVECTOR_LENGTH (v
);
1869 if (SCM_FALSEP (obj
))
1870 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1872 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1874 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1875 SCM_BITVEC_CLR(v
,k
);
1877 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1878 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1880 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1882 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1883 SCM_BITVEC_SET(v
,k
);
1886 badarg3
:SCM_WTA (3,obj
);
1889 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1890 if (SCM_FALSEP (obj
))
1891 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1892 SCM_UNPACK (SCM_VELTS (v
)[k
]) &= ~ SCM_UNPACK(SCM_VELTS (kv
)[k
]);
1893 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1894 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1895 SCM_UNPACK (SCM_VELTS (v
)[k
]) |= SCM_UNPACK (SCM_VELTS (kv
)[k
]);
1900 return SCM_UNSPECIFIED
;
1905 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1906 (SCM v
, SCM kv
, SCM obj
),
1909 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1911 "@var{bv} is not modified.")
1912 #define FUNC_NAME s_scm_bit_count_star
1914 register long i
, vlen
, count
= 0;
1915 register unsigned long k
;
1918 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1919 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1920 switch SCM_TYP7 (kv
)
1926 vlen
= SCM_BITVECTOR_LENGTH (v
);
1927 if (SCM_FALSEP (obj
))
1928 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1930 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1932 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1933 if (!SCM_BITVEC_REF(v
,k
))
1936 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1937 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1939 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1941 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1942 if (SCM_BITVEC_REF (v
,k
))
1946 badarg3
:SCM_WTA (3,obj
);
1949 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1950 if (0 == SCM_BITVECTOR_LENGTH (v
))
1952 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1953 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1954 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1955 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1956 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1960 count
+= cnt_tab
[k
& 0x0f];
1962 return SCM_MAKINUM (count
);
1964 /* urg. repetitive (see above.) */
1965 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
1968 return SCM_MAKINUM (count
);
1973 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1975 "Modifies @var{bv} by replacing each element with its negation.")
1976 #define FUNC_NAME s_scm_bit_invert_x
1980 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1982 k
= SCM_BITVECTOR_LENGTH (v
);
1983 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1984 SCM_UNPACK (SCM_VELTS (v
)[k
]) = ~SCM_UNPACK (SCM_VELTS (v
)[k
]);
1986 return SCM_UNSPECIFIED
;
1992 scm_istr2bve (char *str
, long len
)
1994 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
1995 long *data
= (long *) SCM_VELTS (v
);
1996 register unsigned long mask
;
1999 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2002 j
= len
- k
* SCM_LONG_BIT
;
2003 if (j
> SCM_LONG_BIT
)
2005 for (mask
= 1L; j
--; mask
<<= 1)
2023 ra2l (SCM ra
,scm_sizet base
,scm_sizet k
)
2025 register SCM res
= SCM_EOL
;
2026 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2027 register scm_sizet i
;
2028 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2030 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2031 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2036 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2044 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2051 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2053 "Returns a list consisting of all the elements, in order, of @var{array}.")
2054 #define FUNC_NAME s_scm_array_to_list
2058 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2062 badarg1
:SCM_WTA (1,v
);
2064 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2065 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2066 case scm_tc7_vector
:
2068 return scm_vector_to_list (v
);
2069 case scm_tc7_string
:
2070 return scm_string_to_list (v
);
2073 long *data
= (long *) SCM_VELTS (v
);
2074 register unsigned long mask
;
2075 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2076 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2077 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2078 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2079 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2082 case scm_tc7_uvect
: {
2083 long *data
= (long *)SCM_VELTS(v
);
2084 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2085 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2088 case scm_tc7_ivect
: {
2089 long *data
= (long *)SCM_VELTS(v
);
2090 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2091 res
= scm_cons(scm_long2num(data
[k
]), res
);
2094 case scm_tc7_svect
: {
2096 data
= (short *)SCM_VELTS(v
);
2097 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2098 res
= scm_cons(SCM_MAKINUM (data
[k
]), res
);
2101 #ifdef HAVE_LONG_LONGS
2102 case scm_tc7_llvect
: {
2104 data
= (long_long
*)SCM_VELTS(v
);
2105 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2106 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2114 float *data
= (float *) SCM_VELTS (v
);
2115 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2116 res
= scm_cons (scm_make_real (data
[k
]), res
);
2121 double *data
= (double *) SCM_VELTS (v
);
2122 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2123 res
= scm_cons (scm_make_real (data
[k
]), res
);
2128 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2129 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2130 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2138 static char s_bad_ralst
[] = "Bad scm_array contents list";
2140 static int l2ra(SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
);
2142 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2143 (SCM ndim
, SCM prot
, SCM lst
),
2144 "@deffnx procedure list->uniform-vector prot lst\n"
2145 "Returns a uniform array of the type indicated by prototype @var{prot}\n"
2146 "with elements the same as those of @var{lst}. Elements must be of the\n"
2147 "appropriate type, no coercions are done.")
2148 #define FUNC_NAME s_scm_list_to_uniform_array
2155 SCM_VALIDATE_INUM_COPY (1,ndim
,k
);
2158 n
= scm_ilength (row
);
2159 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2160 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2162 row
= SCM_CAR (row
);
2164 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2166 if (SCM_NULLP (shp
))
2169 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2170 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2173 if (!SCM_ARRAYP (ra
))
2175 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2176 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2177 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2180 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2183 badlst
:scm_wta (lst
, s_bad_ralst
, FUNC_NAME
);
2189 l2ra (SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
)
2191 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2192 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2195 return (SCM_NULLP (lst
));
2196 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2200 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2202 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2204 lst
= SCM_CDR (lst
);
2206 if (SCM_NNULLP (lst
))
2213 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2215 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2217 lst
= SCM_CDR (lst
);
2219 if (SCM_NNULLP (lst
))
2227 rapr1 (SCM ra
,scm_sizet j
,scm_sizet k
,SCM port
,scm_print_state
*pstate
)
2230 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2232 : SCM_INUM (scm_uniform_vector_length (ra
)));
2235 switch SCM_TYP7 (ra
)
2240 SCM_ARRAY_BASE (ra
) = j
;
2242 scm_iprin1 (ra
, port
, pstate
);
2243 for (j
+= inc
; n
-- > 0; j
+= inc
)
2245 scm_putc (' ', port
);
2246 SCM_ARRAY_BASE (ra
) = j
;
2247 scm_iprin1 (ra
, port
, pstate
);
2251 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2254 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2255 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2257 scm_putc ('(', port
);
2258 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2259 scm_puts (") ", port
);
2262 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2263 { /* could be zero size. */
2264 scm_putc ('(', port
);
2265 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2266 scm_putc (')', port
);
2272 { /* Could be zero-dimensional */
2273 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2274 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2278 ra
= SCM_ARRAY_V (ra
);
2281 /* scm_tc7_bvect and scm_tc7_llvect only? */
2283 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2284 for (j
+= inc
; n
-- > 0; j
+= inc
)
2286 scm_putc (' ', port
);
2287 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2290 case scm_tc7_string
:
2292 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2293 if (SCM_WRITINGP (pstate
))
2294 for (j
+= inc
; n
-- > 0; j
+= inc
)
2296 scm_putc (' ', port
);
2297 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2300 for (j
+= inc
; n
-- > 0; j
+= inc
)
2301 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2303 case scm_tc7_byvect
:
2305 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2306 for (j
+= inc
; n
-- > 0; j
+= inc
)
2308 scm_putc (' ', port
);
2309 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2319 /* intprint can't handle >= 2^31. */
2320 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2321 scm_puts (str
, port
);
2323 for (j
+= inc
; n
-- > 0; j
+= inc
)
2325 scm_putc (' ', port
);
2326 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2327 scm_puts (str
, port
);
2332 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2333 for (j
+= inc
; n
-- > 0; j
+= inc
)
2335 scm_putc (' ', port
);
2336 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2342 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2343 for (j
+= inc
; n
-- > 0; j
+= inc
)
2345 scm_putc (' ', port
);
2346 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2353 SCM z
= scm_make_real (1.0);
2354 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2355 scm_print_real (z
, port
, pstate
);
2356 for (j
+= inc
; n
-- > 0; j
+= inc
)
2358 scm_putc (' ', port
);
2359 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2360 scm_print_real (z
, port
, pstate
);
2367 SCM z
= scm_make_real (1.0 / 3.0);
2368 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2369 scm_print_real (z
, port
, pstate
);
2370 for (j
+= inc
; n
-- > 0; j
+= inc
)
2372 scm_putc (' ', port
);
2373 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2374 scm_print_real (z
, port
, pstate
);
2381 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2382 SCM_REAL_VALUE (z
) =
2383 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2384 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2385 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2387 for (j
+= inc
; n
-- > 0; j
+= inc
)
2389 scm_putc (' ', port
);
2391 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2392 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2393 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2404 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2408 scm_putc ('#', port
);
2414 long ndim
= SCM_ARRAY_NDIM (v
);
2415 base
= SCM_ARRAY_BASE (v
);
2416 v
= SCM_ARRAY_V (v
);
2420 scm_puts ("<enclosed-array ", port
);
2421 rapr1 (exp
, base
, 0, port
, pstate
);
2422 scm_putc ('>', port
);
2427 scm_intprint (ndim
, 10, port
);
2432 if (SCM_EQ_P (exp
, v
))
2433 { /* a uve, not an scm_array */
2434 register long i
, j
, w
;
2435 scm_putc ('*', port
);
2436 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2438 scm_bits_t w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2439 for (j
= SCM_LONG_BIT
; j
; j
--)
2441 scm_putc (w
& 1 ? '1' : '0', port
);
2445 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2448 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2451 scm_putc (w
& 1 ? '1' : '0', port
);
2458 scm_putc ('b', port
);
2460 case scm_tc7_string
:
2461 scm_putc ('a', port
);
2463 case scm_tc7_byvect
:
2464 scm_putc ('y', port
);
2467 scm_putc ('u', port
);
2470 scm_putc ('e', port
);
2473 scm_putc ('h', port
);
2475 #ifdef HAVE_LONG_LONGS
2476 case scm_tc7_llvect
:
2477 scm_putc ('l', port
);
2481 scm_putc ('s', port
);
2484 scm_putc ('i', port
);
2487 scm_putc ('c', port
);
2490 scm_putc ('(', port
);
2491 rapr1 (exp
, base
, 0, port
, pstate
);
2492 scm_putc (')', port
);
2496 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2498 "Returns an object that would produce an array of the same type as\n"
2499 "@var{array}, if used as the @var{prototype} for\n"
2500 "@code{make-uniform-array}.")
2501 #define FUNC_NAME s_scm_array_prototype
2504 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2506 switch SCM_TYP7 (ra
)
2509 badarg
:SCM_WTA (1,ra
);
2511 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2513 return SCM_UNSPECIFIED
;
2514 ra
= SCM_ARRAY_V (ra
);
2516 case scm_tc7_vector
:
2521 case scm_tc7_string
:
2522 return SCM_MAKE_CHAR ('a');
2523 case scm_tc7_byvect
:
2524 return SCM_MAKE_CHAR ('\0');
2526 return SCM_MAKINUM (1L);
2528 return SCM_MAKINUM (-1L);
2530 return scm_str2symbol ("s");
2531 #ifdef HAVE_LONG_LONGS
2532 case scm_tc7_llvect
:
2533 return scm_str2symbol ("l");
2536 return scm_make_real (1.0);
2538 return scm_make_real (1.0 / 3.0);
2540 return scm_make_complex (0.0, 1.0);
2547 array_mark (SCM ptr
)
2549 return SCM_ARRAY_V (ptr
);
2554 array_free (SCM ptr
)
2556 scm_must_free (SCM_ARRAY_MEM (ptr
));
2557 return sizeof (scm_array
) + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_array_dim
);
2563 scm_tc16_array
= scm_make_smob_type ("array", 0);
2564 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2565 scm_set_smob_free (scm_tc16_array
, array_free
);
2566 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2567 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2568 scm_add_feature ("array");
2569 #ifndef SCM_MAGIC_SNARFER
2570 #include "libguile/unif.x"