1 /* Copyright (C) 1995,1996,1997,1998, 2000 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
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 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_LENGTH_MAX
);
163 if (SCM_EQ_P (prot
, SCM_BOOL_T
))
165 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
166 type
= scm_tc7_bvect
;
168 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
170 i
= sizeof (char) * k
;
171 type
= scm_tc7_byvect
;
173 else if (SCM_CHARP (prot
))
175 i
= sizeof (char) * k
;
176 type
= scm_tc7_string
;
178 else if (SCM_INUMP (prot
))
180 i
= sizeof (long) * k
;
181 if (SCM_INUM (prot
) > 0)
182 type
= scm_tc7_uvect
;
184 type
= scm_tc7_ivect
;
186 else if (SCM_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
190 s
= SCM_SYMBOL_CHARS (prot
)[0];
193 i
= sizeof (short) * k
;
194 type
= scm_tc7_svect
;
196 #ifdef HAVE_LONG_LONGS
199 i
= sizeof (long_long
) * k
;
200 type
= scm_tc7_llvect
;
205 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
209 if (SCM_IMP (prot
) || !SCM_INEXACTP (prot
))
210 /* Huge non-unif vectors are NOT supported. */
211 /* no special scm_vector */
212 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
213 else if (singp (prot
))
215 i
= sizeof (float) * k
;
216 type
= scm_tc7_fvect
;
218 else if (SCM_COMPLEXP (prot
))
220 i
= 2 * sizeof (double) * k
;
221 type
= scm_tc7_cvect
;
225 i
= sizeof (double) * k
;
226 type
= scm_tc7_dvect
;
231 SCM_SETCHARS (v
, (char *) scm_must_malloc (i
? i
: 1, "vector"));
232 SCM_SETLENGTH (v
, k
, type
);
239 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
241 "Returns the number of elements in @var{uve}.")
242 #define FUNC_NAME s_scm_uniform_vector_length
244 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
248 badarg1
:SCM_WTA(1,v
);
251 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v
));
253 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
255 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
263 #ifdef HAVE_LONG_LONGS
266 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v
));
271 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
273 "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n"
274 "The @var{prototype} argument is used with uniform arrays and is described\n"
276 #define FUNC_NAME s_scm_array_p
280 nprot
= SCM_UNBNDP (prot
);
285 while (SCM_TYP7 (v
) == scm_tc7_smob
)
296 return SCM_BOOL(nprot
);
301 switch (SCM_TYP7 (v
))
304 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
306 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
308 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
310 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
312 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
315 protp
= SCM_SYMBOLP (prot
)
316 && (1 == SCM_SYMBOL_LENGTH (prot
))
317 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
318 #ifdef HAVE_LONG_LONGS
320 protp
= SCM_SYMBOLP (prot
)
321 && (1 == SCM_SYMBOL_LENGTH (prot
))
322 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
325 protp
= singp (prot
);
327 protp
= SCM_REALP(prot
);
329 protp
= SCM_COMPLEXP(prot
);
332 protp
= SCM_NULLP(prot
);
337 return SCM_BOOL(protp
);
343 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
345 "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n"
346 "array, @code{0} is returned.")
347 #define FUNC_NAME s_scm_array_rank
351 switch (SCM_TYP7 (ra
))
364 #ifdef HAVE_LONG_LONGS
368 return SCM_MAKINUM (1L);
371 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
378 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
380 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
381 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
383 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
385 #define FUNC_NAME s_scm_array_dimensions
392 switch (SCM_TYP7 (ra
))
407 #ifdef HAVE_LONG_LONGS
410 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
412 if (!SCM_ARRAYP (ra
))
414 k
= SCM_ARRAY_NDIM (ra
);
415 s
= SCM_ARRAY_DIMS (ra
);
417 res
= scm_cons (s
[k
].lbnd
418 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
419 SCM_MAKINUM (s
[k
].ubnd
),
421 : SCM_MAKINUM (1 + s
[k
].ubnd
),
429 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
431 "Return the root vector of a shared array.")
432 #define FUNC_NAME s_scm_shared_array_root
434 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
435 return SCM_ARRAY_V (ra
);
440 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
442 "Return the root vector index of the first element in the array.")
443 #define FUNC_NAME s_scm_shared_array_offset
445 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
446 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
451 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
453 "For each dimension, return the distance between elements in the root vector.")
454 #define FUNC_NAME s_scm_shared_array_increments
459 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
460 k
= SCM_ARRAY_NDIM (ra
);
461 s
= SCM_ARRAY_DIMS (ra
);
463 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
469 static char s_bad_ind
[] = "Bad scm_array index";
473 scm_aind (SCM ra
, SCM args
, const char *what
)
477 register scm_sizet pos
= SCM_ARRAY_BASE (ra
);
478 register scm_sizet k
= SCM_ARRAY_NDIM (ra
);
479 scm_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
480 if (SCM_INUMP (args
))
482 SCM_ASSERT (1 == k
, scm_makfrom0str (what
), SCM_WNA
, NULL
);
483 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
485 while (k
&& SCM_NIMP (args
))
487 ind
= SCM_CAR (args
);
488 args
= SCM_CDR (args
);
489 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, what
);
491 if (j
< s
->lbnd
|| j
> s
->ubnd
)
492 scm_out_of_range (what
, ind
);
493 pos
+= (j
- s
->lbnd
) * (s
->inc
);
497 SCM_ASSERT (0 == k
&& SCM_NULLP (args
), scm_makfrom0str (what
), SCM_WNA
,
505 scm_make_ra (int ndim
)
510 SCM_NEWSMOB(ra
, ((long) ndim
<< 17) + scm_tc16_array
,
511 scm_must_malloc ((long) (sizeof (scm_array
) + ndim
* sizeof (scm_array_dim
)),
513 SCM_ARRAY_V (ra
) = scm_nullvect
;
518 static char s_bad_spec
[] = "Bad scm_array dimension";
519 /* Increments will still need to be set. */
523 scm_shap2ra (SCM args
, const char *what
)
527 int ndim
= scm_ilength (args
);
528 SCM_ASSERT (0 <= ndim
, args
, s_bad_spec
, what
);
529 ra
= scm_make_ra (ndim
);
530 SCM_ARRAY_BASE (ra
) = 0;
531 s
= SCM_ARRAY_DIMS (ra
);
532 for (; !SCM_NULLP (args
); s
++, args
= SCM_CDR (args
))
534 spec
= SCM_CAR (args
);
535 if (SCM_INUMP (spec
))
537 SCM_ASSERT (SCM_INUM (spec
) >= 0, spec
, s_bad_spec
, what
);
539 s
->ubnd
= SCM_INUM (spec
) - 1;
544 SCM_ASSERT (SCM_CONSP (spec
) && SCM_INUMP (SCM_CAR (spec
)), spec
,
546 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
548 SCM_ASSERT (SCM_CONSP (sp
)
549 && SCM_INUMP (SCM_CAR (sp
)) && SCM_NULLP (SCM_CDR (sp
)),
550 spec
, s_bad_spec
, what
);
551 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
558 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
559 (SCM dims
, SCM prot
, SCM fill
),
560 "@deffnx primitive make-uniform-vector length prototype [fill]\n"
561 "Creates and returns a uniform array or vector of type corresponding to\n"
562 "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n"
563 "@var{fill} is supplied, it's used to fill the array, otherwise \n"
564 "@var{prototype} is used.")
565 #define FUNC_NAME s_scm_dimensions_to_uniform_array
568 unsigned long int rlen
= 1;
571 if (SCM_INUMP (dims
))
575 SCM_ASSERT_RANGE (1, dims
, SCM_INUM (dims
) <= SCM_LENGTH_MAX
);
577 answer
= scm_make_uve (SCM_INUM (dims
), prot
);
578 if (!SCM_UNBNDP (fill
))
579 scm_array_fill_x (answer
, fill
);
580 else if (SCM_SYMBOLP (prot
))
581 scm_array_fill_x (answer
, SCM_MAKINUM (0));
583 scm_array_fill_x (answer
, prot
);
586 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
587 dims
, SCM_ARG1
, FUNC_NAME
);
588 ra
= scm_shap2ra (dims
, FUNC_NAME
);
589 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
590 s
= SCM_ARRAY_DIMS (ra
);
591 k
= SCM_ARRAY_NDIM (ra
);
595 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
596 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
599 SCM_ASSERT_RANGE (1, dims
, rlen
<= SCM_LENGTH_MAX
);
601 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
603 if (!SCM_UNBNDP (fill
))
604 scm_array_fill_x (ra
, fill
);
605 else if (SCM_SYMBOLP (prot
))
606 scm_array_fill_x (ra
, SCM_MAKINUM (0));
608 scm_array_fill_x (ra
, prot
);
610 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
611 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
612 return SCM_ARRAY_V (ra
);
619 scm_ra_set_contp (SCM ra
)
621 scm_sizet k
= SCM_ARRAY_NDIM (ra
);
624 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
627 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
629 SCM_SETAND_CAR (ra
, ~SCM_ARRAY_CONTIGUOUS
);
632 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
633 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
636 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
640 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
641 (SCM oldra
, SCM mapfunc
, SCM dims
),
642 "@code{make-shared-array} can be used to create shared subarrays of other\n"
643 "arrays. The @var{mapper} is a function that translates coordinates in\n"
644 "the new array into coordinates in the old array. A @var{mapper} must be\n"
645 "linear, and its range must stay within the bounds of the old array, but\n"
646 "it can be otherwise arbitrary. A simple example:\n"
648 "(define fred (make-array #f 8 8))\n"
649 "(define freds-diagonal\n"
650 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
651 "(array-set! freds-diagonal 'foo 3)\n"
652 "(array-ref fred 3 3) @result{} foo\n"
653 "(define freds-center\n"
654 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
655 "(array-ref freds-center 0 0) @result{} foo\n"
657 #define FUNC_NAME s_scm_make_shared_array
663 long old_min
, new_min
, old_max
, new_max
;
665 SCM_VALIDATE_ARRAY (1,oldra
);
666 SCM_VALIDATE_PROC (2,mapfunc
);
667 ra
= scm_shap2ra (dims
, FUNC_NAME
);
668 if (SCM_ARRAYP (oldra
))
670 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
671 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
672 s
= SCM_ARRAY_DIMS (oldra
);
673 k
= SCM_ARRAY_NDIM (oldra
);
677 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
679 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
684 SCM_ARRAY_V (ra
) = oldra
;
686 old_max
= SCM_INUM (scm_uniform_vector_length (oldra
)) - 1;
689 s
= SCM_ARRAY_DIMS (ra
);
690 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
692 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
693 if (s
[k
].ubnd
< s
[k
].lbnd
)
695 if (1 == SCM_ARRAY_NDIM (ra
))
696 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
698 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
702 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
703 if (SCM_ARRAYP (oldra
))
704 i
= (scm_sizet
) scm_aind (oldra
, imap
, FUNC_NAME
);
707 if (SCM_NINUMP (imap
))
710 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
711 imap
, s_bad_ind
, FUNC_NAME
);
712 imap
= SCM_CAR (imap
);
716 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
718 k
= SCM_ARRAY_NDIM (ra
);
721 if (s
[k
].ubnd
> s
[k
].lbnd
)
723 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
724 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
725 if (SCM_ARRAYP (oldra
))
727 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
730 if (SCM_NINUMP (imap
))
733 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
734 imap
, s_bad_ind
, FUNC_NAME
);
735 imap
= SCM_CAR (imap
);
737 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
741 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
743 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
746 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
747 indptr
= SCM_CDR (indptr
);
749 SCM_ASSERT (old_min
<= new_min
&& old_max
>= new_max
, SCM_UNDEFINED
,
750 "mapping out of range", FUNC_NAME
);
751 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
753 SCM v
= SCM_ARRAY_V (ra
);
754 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
755 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
757 if (s
->ubnd
< s
->lbnd
)
758 return scm_make_uve (0L, scm_array_prototype (ra
));
760 scm_ra_set_contp (ra
);
766 /* args are RA . DIMS */
767 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
769 "Returns an array sharing contents with @var{array}, but with dimensions\n"
770 "arranged in a different order. There must be one @var{dim} argument for\n"
771 "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n"
772 "be integers between 0 and the rank of the array to be returned. Each\n"
773 "integer in that range must appear at least once in the argument list.\n\n"
774 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n"
775 "in the array to be returned, their positions in the argument list to\n"
776 "dimensions of @var{array}. Several @var{dim}s may have the same value,\n"
777 "in which case the returned array will have smaller rank than\n"
781 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
782 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
783 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
784 " #2((a 4) (b 5) (c 6))\n"
786 #define FUNC_NAME s_scm_transpose_array
788 SCM res
, vargs
, *ve
= &vargs
;
789 scm_array_dim
*s
, *r
;
792 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
793 switch (SCM_TYP7 (ra
))
796 badarg
:SCM_WTA (1,ra
);
806 #ifdef HAVE_LONG_LONGS
809 SCM_ASSERT (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
810 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
811 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), SCM_CAR (args
), SCM_ARG2
,
813 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
814 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
817 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
818 vargs
= scm_vector (args
);
819 SCM_ASSERT (SCM_VECTOR_LENGTH (vargs
) == SCM_ARRAY_NDIM (ra
),
820 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
821 ve
= SCM_VELTS (vargs
);
823 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
825 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
827 i
= SCM_INUM (ve
[k
]);
828 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
829 scm_out_of_range (FUNC_NAME
, ve
[k
]);
834 res
= scm_make_ra (ndim
);
835 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
836 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
839 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
840 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
842 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
844 i
= SCM_INUM (ve
[k
]);
845 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
846 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
847 if (r
->ubnd
< r
->lbnd
)
856 if (r
->ubnd
> s
->ubnd
)
858 if (r
->lbnd
< s
->lbnd
)
860 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
866 SCM_ASSERT (ndim
<= 0, args
, "bad argument list", FUNC_NAME
);
867 scm_ra_set_contp (res
);
873 /* args are RA . AXES */
874 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
876 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
877 "the rank of @var{array}. @var{enclose-array} returns an array\n"
878 "resembling an array of shared arrays. The dimensions of each shared\n"
879 "array are the same as the @var{dim}th dimensions of the original array,\n"
880 "the dimensions of the outer array are the same as those of the original\n"
881 "array that did not match a @var{dim}.\n\n"
882 "An enclosed array is not a general Scheme array. Its elements may not\n"
883 "be set using @code{array-set!}. Two references to the same element of\n"
884 "an enclosed array will be @code{equal?} but will not in general be\n"
885 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
886 "enclosed array is unspecified.\n\n"
889 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
890 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
891 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
892 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
894 #define FUNC_NAME s_scm_enclose_array
896 SCM axv
, res
, ra_inr
;
897 scm_array_dim vdim
, *s
= &vdim
;
898 int ndim
, j
, k
, ninr
, noutr
;
900 if (SCM_NULLP (axes
))
901 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
902 ninr
= scm_ilength (axes
);
903 SCM_ASSERT (0 <= ninr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
904 ra_inr
= scm_make_ra (ninr
);
905 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
909 badarg1
:SCM_WTA (1,ra
);
921 #ifdef HAVE_LONG_LONGS
925 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
927 SCM_ARRAY_V (ra_inr
) = ra
;
928 SCM_ARRAY_BASE (ra_inr
) = 0;
932 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
933 s
= SCM_ARRAY_DIMS (ra
);
934 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
935 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
936 ndim
= SCM_ARRAY_NDIM (ra
);
940 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
941 SCM_ASSERT (0 <= noutr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
942 res
= scm_make_ra (noutr
);
943 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
944 SCM_ARRAY_V (res
) = ra_inr
;
945 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
947 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes
)), SCM_CAR (axes
), "bad axis", FUNC_NAME
);
948 j
= SCM_INUM (SCM_CAR (axes
));
949 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
950 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
951 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
952 SCM_STRING_CHARS (axv
)[j
] = 1;
954 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
956 while (SCM_STRING_CHARS (axv
)[j
])
958 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
959 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
960 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
962 scm_ra_set_contp (ra_inr
);
963 scm_ra_set_contp (res
);
970 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
972 "Returns @code{#t} if its arguments would be acceptable to array-ref.")
973 #define FUNC_NAME s_scm_array_in_bounds_p
977 register scm_sizet k
;
981 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
985 ind
= SCM_CAR (args
);
986 args
= SCM_CDR (args
);
987 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
988 pos
= SCM_INUM (ind
);
994 badarg1
:SCM_WTA (1,v
);
995 wna
: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME
));
997 k
= SCM_ARRAY_NDIM (v
);
998 s
= SCM_ARRAY_DIMS (v
);
999 pos
= SCM_ARRAY_BASE (v
);
1002 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1009 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1011 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1014 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1015 if (!(--k
&& SCM_NIMP (args
)))
1017 ind
= SCM_CAR (args
);
1018 args
= SCM_CDR (args
);
1020 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, FUNC_NAME
);
1022 SCM_ASRTGO (0 == k
, wna
);
1023 v
= SCM_ARRAY_V (v
);
1026 case scm_tc7_string
:
1027 case scm_tc7_byvect
:
1034 #ifdef HAVE_LONG_LONGS
1035 case scm_tc7_llvect
:
1037 case scm_tc7_vector
:
1040 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1041 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1042 return SCM_BOOL(pos
>= 0 && pos
< length
);
1049 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1052 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1054 "@deffnx primitive array-ref v . args\n"
1055 "Returns the element at the @code{(index1, index2)} element in @var{array}.")
1056 #define FUNC_NAME s_scm_uniform_vector_ref
1062 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1065 else if (SCM_ARRAYP (v
))
1067 pos
= scm_aind (v
, args
, FUNC_NAME
);
1068 v
= SCM_ARRAY_V (v
);
1072 unsigned long int length
;
1073 if (SCM_NIMP (args
))
1075 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1076 pos
= SCM_INUM (SCM_CAR (args
));
1077 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1081 SCM_VALIDATE_INUM (2,args
);
1082 pos
= SCM_INUM (args
);
1084 length
= SCM_INUM (scm_uniform_vector_length (v
));
1085 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1090 if (SCM_NULLP (args
))
1097 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1099 scm_wrong_num_args (SCM_FUNC_NAME
);
1102 int k
= SCM_ARRAY_NDIM (v
);
1103 SCM res
= scm_make_ra (k
);
1104 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1105 SCM_ARRAY_BASE (res
) = pos
;
1108 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1109 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1110 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1115 if (SCM_BITVEC_REF (v
, pos
))
1119 case scm_tc7_string
:
1120 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1121 case scm_tc7_byvect
:
1122 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1124 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1126 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1129 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1130 #ifdef HAVE_LONG_LONGS
1131 case scm_tc7_llvect
:
1132 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1136 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1138 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1140 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1141 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1142 case scm_tc7_vector
:
1144 return SCM_VELTS (v
)[pos
];
1149 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1150 tries to recycle conses. (Make *sure* you want them recycled.) */
1153 scm_cvref (SCM v
, scm_sizet pos
, SCM last
)
1158 scm_wta (v
, (char *) SCM_ARG1
, "PROGRAMMING ERROR: scm_cvref");
1160 if (SCM_BITVEC_REF(v
,pos
))
1164 case scm_tc7_string
:
1165 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1166 case scm_tc7_byvect
:
1167 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1169 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1171 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1173 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1174 #ifdef HAVE_LONG_LONGS
1175 case scm_tc7_llvect
:
1176 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1179 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1181 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1184 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1186 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1188 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1191 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1193 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1195 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1196 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1199 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1200 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1201 case scm_tc7_vector
:
1203 return SCM_VELTS (v
)[pos
];
1205 { /* enclosed scm_array */
1206 int k
= SCM_ARRAY_NDIM (v
);
1207 SCM res
= scm_make_ra (k
);
1208 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1209 SCM_ARRAY_BASE (res
) = pos
;
1212 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1213 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1214 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1221 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1224 /* Note that args may be a list or an immediate object, depending which
1225 PROC is used (and it's called from C too). */
1226 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1227 (SCM v
, SCM obj
, SCM args
),
1228 "@deffnx primitive uniform-array-set1! v obj args\n"
1229 "Sets the element at the @code{(index1, index2)} element in @var{array} to\n"
1230 "@var{new-value}. The value returned by array-set! is unspecified.")
1231 #define FUNC_NAME s_scm_array_set_x
1234 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1237 pos
= scm_aind (v
, args
, FUNC_NAME
);
1238 v
= SCM_ARRAY_V (v
);
1242 unsigned long int length
;
1243 if (SCM_NIMP (args
))
1245 SCM_ASSERT (SCM_CONSP(args
) && SCM_INUMP (SCM_CAR (args
)), args
,
1246 SCM_ARG3
, FUNC_NAME
);
1247 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1248 pos
= SCM_INUM (SCM_CAR (args
));
1252 SCM_VALIDATE_INUM_COPY (3,args
,pos
);
1254 length
= SCM_INUM (scm_uniform_vector_length (v
));
1255 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1257 switch (SCM_TYP7 (v
))
1263 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1265 scm_wrong_num_args (SCM_FUNC_NAME
);
1266 case scm_tc7_smob
: /* enclosed */
1269 if (SCM_FALSEP (obj
))
1270 SCM_BITVEC_CLR(v
,pos
);
1271 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1272 SCM_BITVEC_SET(v
,pos
);
1274 badobj
:SCM_WTA (2,obj
);
1276 case scm_tc7_string
:
1277 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1278 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1280 case scm_tc7_byvect
:
1281 if (SCM_CHARP (obj
))
1282 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1283 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1284 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1287 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2ulong(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1290 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2long(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1293 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1294 ((short *) SCM_CELL_WORD_1 (v
))[pos
] = SCM_INUM (obj
);
1296 #ifdef HAVE_LONG_LONGS
1297 case scm_tc7_llvect
:
1298 ((long_long
*) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2long_long (obj
, (char *)SCM_ARG2
, FUNC_NAME
);
1304 ((float *) SCM_CELL_WORD_1 (v
))[pos
] = (float) scm_num2dbl (obj
, FUNC_NAME
);
1307 ((double *) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2dbl (obj
, FUNC_NAME
);
1310 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1311 if (SCM_REALP (obj
)) {
1312 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1313 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = 0.0;
1315 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1316 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1319 case scm_tc7_vector
:
1321 SCM_VELTS (v
)[pos
] = obj
;
1324 return SCM_UNSPECIFIED
;
1328 /* attempts to unroll an array into a one-dimensional array.
1329 returns the unrolled array or #f if it can't be done. */
1330 /* if strict is not SCM_UNDEFINED, return #f if returned array
1331 wouldn't have contiguous elements. */
1332 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1333 (SCM ra
, SCM strict
),
1334 "@deffnx primitive array-contents array strict\n"
1335 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1336 "without changing their order (last subscript changing fastest), then\n"
1337 "@code{array-contents} returns that shared array, otherwise it returns\n"
1338 "@code{#f}. All arrays made by @var{make-array} and\n"
1339 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1340 "@var{make-shared-array} may not be.\n\n"
1341 "If the optional argument @var{strict} is provided, a shared array will\n"
1342 "be returned only if its elements are stored internally contiguous in\n"
1344 #define FUNC_NAME s_scm_array_contents
1349 switch SCM_TYP7 (ra
)
1353 case scm_tc7_vector
:
1355 case scm_tc7_string
:
1357 case scm_tc7_byvect
:
1364 #ifdef HAVE_LONG_LONGS
1365 case scm_tc7_llvect
:
1370 scm_sizet k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1371 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1373 for (k
= 0; k
< ndim
; k
++)
1374 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1375 if (!SCM_UNBNDP (strict
))
1377 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1379 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1381 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1382 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1389 SCM v
= SCM_ARRAY_V (ra
);
1390 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1391 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1395 sra
= scm_make_ra (1);
1396 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1397 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1398 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1399 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1400 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1409 scm_ra2contig (SCM ra
, int copy
)
1413 scm_sizet k
, len
= 1;
1414 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1415 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1416 k
= SCM_ARRAY_NDIM (ra
);
1417 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1419 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1421 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1422 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1423 0 == len
% SCM_LONG_BIT
))
1426 ret
= scm_make_ra (k
);
1427 SCM_ARRAY_BASE (ret
) = 0;
1430 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1431 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1432 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1433 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1435 SCM_ARRAY_V (ret
) = scm_make_uve ((inc
- 1), scm_array_prototype (ra
));
1437 scm_array_copy_x (ra
, ret
);
1443 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1444 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1445 "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1446 "Attempts to read all elements of @var{ura}, in lexicographic order, as\n"
1447 "binary objects from @var{port-or-fdes}.\n"
1448 "If an end of file is encountered during\n"
1449 "uniform-array-read! the objects up to that point only are put into @var{ura}\n"
1450 "(starting at the beginning) and the remainder of the array is\n"
1452 "The optional arguments @var{start} and @var{end} allow\n"
1453 "a specified region of a vector (or linearized array) to be read,\n"
1454 "leaving the remainder of the vector unchanged.\n\n"
1455 "@code{uniform-array-read!} returns the number of objects read.\n"
1456 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1457 "returned by @code{(current-input-port)}.")
1458 #define FUNC_NAME s_scm_uniform_array_read_x
1460 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1467 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1468 if (SCM_UNBNDP (port_or_fd
))
1469 port_or_fd
= scm_cur_inp
;
1471 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1472 || (SCM_OPINPORTP (port_or_fd
)),
1473 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1474 vlen
= SCM_INUM (scm_uniform_vector_length (v
));
1480 badarg1
:SCM_WTA (SCM_ARG1
,v
);
1482 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1483 cra
= scm_ra2contig (ra
, 0);
1484 cstart
+= SCM_ARRAY_BASE (cra
);
1485 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1486 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1487 v
= SCM_ARRAY_V (cra
);
1489 case scm_tc7_string
:
1490 base
= SCM_STRING_CHARS (v
);
1494 base
= (char *) SCM_BITVECTOR_BASE (v
);
1495 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1496 cstart
/= SCM_LONG_BIT
;
1499 case scm_tc7_byvect
:
1500 base
= (char *) SCM_UVECTOR_BASE (v
);
1505 base
= (char *) SCM_UVECTOR_BASE (v
);
1509 base
= (char *) SCM_UVECTOR_BASE (v
);
1510 sz
= sizeof (short);
1512 #ifdef HAVE_LONG_LONGS
1513 case scm_tc7_llvect
:
1514 base
= (char *) SCM_UVECTOR_BASE (v
);
1515 sz
= sizeof (long_long
);
1519 base
= (char *) SCM_UVECTOR_BASE (v
);
1520 sz
= sizeof (float);
1523 base
= (char *) SCM_UVECTOR_BASE (v
);
1524 sz
= sizeof (double);
1527 base
= (char *) SCM_UVECTOR_BASE (v
);
1528 sz
= 2 * sizeof (double);
1533 if (!SCM_UNBNDP (start
))
1536 SCM_NUM2LONG (3, start
);
1538 if (offset
< 0 || offset
>= cend
)
1539 scm_out_of_range (FUNC_NAME
, start
);
1541 if (!SCM_UNBNDP (end
))
1544 SCM_NUM2LONG (4, end
);
1546 if (tend
<= offset
|| tend
> cend
)
1547 scm_out_of_range (FUNC_NAME
, end
);
1552 if (SCM_NIMP (port_or_fd
))
1554 scm_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1555 int remaining
= (cend
- offset
) * sz
;
1556 char *dest
= base
+ (cstart
+ offset
) * sz
;
1558 if (pt
->rw_active
== SCM_PORT_WRITE
)
1559 scm_flush (port_or_fd
);
1561 ans
= cend
- offset
;
1562 while (remaining
> 0)
1564 if (pt
->read_pos
< pt
->read_end
)
1566 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1569 memcpy (dest
, pt
->read_pos
, to_copy
);
1570 pt
->read_pos
+= to_copy
;
1571 remaining
-= to_copy
;
1576 if (scm_fill_input (port_or_fd
) == EOF
)
1578 if (remaining
% sz
!= 0)
1580 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1582 ans
-= remaining
/ sz
;
1589 pt
->rw_active
= SCM_PORT_READ
;
1591 else /* file descriptor. */
1593 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1594 base
+ (cstart
+ offset
) * sz
,
1595 (scm_sizet
) (sz
* (cend
- offset
))));
1599 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1600 ans
*= SCM_LONG_BIT
;
1602 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1603 scm_array_copy_x (cra
, ra
);
1605 return SCM_MAKINUM (ans
);
1609 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1610 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1611 "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1612 "Writes all elements of @var{ura} as binary objects to\n"
1613 "@var{port-or-fdes}.\n\n"
1614 "The optional arguments @var{start}\n"
1615 "and @var{end} allow\n"
1616 "a specified region of a vector (or linearized array) to be written.\n\n"
1617 "The number of objects actually written is returned. \n"
1618 "@var{port-or-fdes} may be\n"
1619 "omitted, in which case it defaults to the value returned by\n"
1620 "@code{(current-output-port)}.")
1621 #define FUNC_NAME s_scm_uniform_array_write
1629 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1631 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1632 if (SCM_UNBNDP (port_or_fd
))
1633 port_or_fd
= scm_cur_outp
;
1635 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1636 || (SCM_OPOUTPORTP (port_or_fd
)),
1637 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1638 vlen
= SCM_INUM (scm_uniform_vector_length (v
));
1644 badarg1
:SCM_WTA (1, v
);
1646 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1647 v
= scm_ra2contig (v
, 1);
1648 cstart
= SCM_ARRAY_BASE (v
);
1649 vlen
= SCM_ARRAY_DIMS (v
)->inc
1650 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1651 v
= SCM_ARRAY_V (v
);
1653 case scm_tc7_string
:
1654 base
= SCM_STRING_CHARS (v
);
1658 base
= (char *) SCM_BITVECTOR_BASE (v
);
1659 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1660 cstart
/= SCM_LONG_BIT
;
1663 case scm_tc7_byvect
:
1664 base
= (char *) SCM_UVECTOR_BASE (v
);
1669 base
= (char *) SCM_UVECTOR_BASE (v
);
1673 base
= (char *) SCM_UVECTOR_BASE (v
);
1674 sz
= sizeof (short);
1676 #ifdef HAVE_LONG_LONGS
1677 case scm_tc7_llvect
:
1678 base
= (char *) SCM_UVECTOR_BASE (v
);
1679 sz
= sizeof (long_long
);
1683 base
= (char *) SCM_UVECTOR_BASE (v
);
1684 sz
= sizeof (float);
1687 base
= (char *) SCM_UVECTOR_BASE (v
);
1688 sz
= sizeof (double);
1691 base
= (char *) SCM_UVECTOR_BASE (v
);
1692 sz
= 2 * sizeof (double);
1697 if (!SCM_UNBNDP (start
))
1700 SCM_NUM2LONG (3, start
);
1702 if (offset
< 0 || offset
>= cend
)
1703 scm_out_of_range (FUNC_NAME
, start
);
1705 if (!SCM_UNBNDP (end
))
1708 SCM_NUM2LONG (4, end
);
1710 if (tend
<= offset
|| tend
> cend
)
1711 scm_out_of_range (FUNC_NAME
, end
);
1716 if (SCM_NIMP (port_or_fd
))
1718 char *source
= base
+ (cstart
+ offset
) * sz
;
1720 ans
= cend
- offset
;
1721 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1723 else /* file descriptor. */
1725 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1726 base
+ (cstart
+ offset
) * sz
,
1727 (scm_sizet
) (sz
* (cend
- offset
))));
1731 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1732 ans
*= SCM_LONG_BIT
;
1734 return SCM_MAKINUM (ans
);
1739 static char cnt_tab
[16] =
1740 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1742 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1743 (SCM b
, SCM bitvector
),
1744 "Returns the number of occurrences of the boolean B in BITVECTOR.")
1745 #define FUNC_NAME s_scm_bit_count
1747 SCM_VALIDATE_BOOL (1, b
);
1748 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1749 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1752 unsigned long int count
= 0;
1753 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1754 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1755 if (SCM_FALSEP (b
)) {
1758 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1761 count
+= cnt_tab
[w
& 0x0f];
1765 return SCM_MAKINUM (count
);
1768 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1769 if (SCM_FALSEP (b
)) {
1779 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1780 (SCM item
, SCM v
, SCM k
),
1781 "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n"
1782 "which is at least @var{k}. If no @var{bool} occurs within the specified\n"
1783 "range @code{#f} is returned.")
1784 #define FUNC_NAME s_scm_bit_position
1786 long i
, lenw
, xbits
, pos
;
1787 register unsigned long w
;
1789 SCM_VALIDATE_BOOL (1, item
);
1790 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1791 SCM_VALIDATE_INUM_COPY (3,k
,pos
);
1792 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1794 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1797 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1798 i
= pos
/ SCM_LONG_BIT
;
1799 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1800 if (SCM_FALSEP (item
))
1802 xbits
= (pos
% SCM_LONG_BIT
);
1804 w
= ((w
>> xbits
) << xbits
);
1805 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1808 if (w
&& (i
== lenw
))
1809 w
= ((w
<< xbits
) >> xbits
);
1815 return SCM_MAKINUM (pos
);
1820 return SCM_MAKINUM (pos
+ 1);
1823 return SCM_MAKINUM (pos
+ 2);
1825 return SCM_MAKINUM (pos
+ 3);
1832 pos
+= SCM_LONG_BIT
;
1833 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1834 if (SCM_FALSEP (item
))
1842 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1843 (SCM v
, SCM kv
, SCM obj
),
1844 "If uve is a bit-vector @var{bv} and uve must be of the same length. If\n"
1845 "@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the\n"
1846 "inversion of uve is AND'ed into @var{bv}.\n\n"
1847 "If uve is a unsigned integer vector all the elements of uve must be\n"
1848 "between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv}\n"
1849 "corresponding to the indexes in uve are set to @var{bool}.\n\n"
1850 "The return value is unspecified.")
1851 #define FUNC_NAME s_scm_bit_set_star_x
1853 register long i
, k
, vlen
;
1854 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1855 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1856 switch SCM_TYP7 (kv
)
1859 badarg2
:SCM_WTA (2,kv
);
1861 vlen
= SCM_BITVECTOR_LENGTH (v
);
1862 if (SCM_FALSEP (obj
))
1863 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1865 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1867 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1868 SCM_BITVEC_CLR(v
,k
);
1870 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1871 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1873 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1875 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1876 SCM_BITVEC_SET(v
,k
);
1879 badarg3
:SCM_WTA (3,obj
);
1882 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1883 if (SCM_FALSEP (obj
))
1884 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1885 SCM_UNPACK (SCM_VELTS (v
)[k
]) &= ~ SCM_UNPACK(SCM_VELTS (kv
)[k
]);
1886 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1887 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1888 SCM_UNPACK (SCM_VELTS (v
)[k
]) |= SCM_UNPACK (SCM_VELTS (kv
)[k
]);
1893 return SCM_UNSPECIFIED
;
1898 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1899 (SCM v
, SCM kv
, SCM obj
),
1902 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1904 "@var{bv} is not modified.")
1905 #define FUNC_NAME s_scm_bit_count_star
1907 register long i
, vlen
, count
= 0;
1908 register unsigned long k
;
1911 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1912 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1913 switch SCM_TYP7 (kv
)
1919 vlen
= SCM_BITVECTOR_LENGTH (v
);
1920 if (SCM_FALSEP (obj
))
1921 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1923 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1925 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1926 if (!SCM_BITVEC_REF(v
,k
))
1929 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1930 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1932 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1934 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1935 if (SCM_BITVEC_REF (v
,k
))
1939 badarg3
:SCM_WTA (3,obj
);
1942 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1943 if (0 == SCM_BITVECTOR_LENGTH (v
))
1945 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1946 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1947 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1948 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1949 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1953 count
+= cnt_tab
[k
& 0x0f];
1955 return SCM_MAKINUM (count
);
1957 /* urg. repetitive (see above.) */
1958 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
1961 return SCM_MAKINUM (count
);
1966 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1968 "Modifies @var{bv} by replacing each element with its negation.")
1969 #define FUNC_NAME s_scm_bit_invert_x
1973 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1975 k
= SCM_BITVECTOR_LENGTH (v
);
1976 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1977 SCM_UNPACK (SCM_VELTS (v
)[k
]) = ~SCM_UNPACK (SCM_VELTS (v
)[k
]);
1979 return SCM_UNSPECIFIED
;
1985 scm_istr2bve (char *str
, long len
)
1987 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
1988 long *data
= (long *) SCM_VELTS (v
);
1989 register unsigned long mask
;
1992 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
1995 j
= len
- k
* SCM_LONG_BIT
;
1996 if (j
> SCM_LONG_BIT
)
1998 for (mask
= 1L; j
--; mask
<<= 1)
2016 ra2l (SCM ra
,scm_sizet base
,scm_sizet k
)
2018 register SCM res
= SCM_EOL
;
2019 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2020 register scm_sizet i
;
2021 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2023 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2024 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2029 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2037 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2044 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2046 "Returns a list consisting of all the elements, in order, of @var{array}.")
2047 #define FUNC_NAME s_scm_array_to_list
2051 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2055 badarg1
:SCM_WTA (1,v
);
2057 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2058 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2059 case scm_tc7_vector
:
2061 return scm_vector_to_list (v
);
2062 case scm_tc7_string
:
2063 return scm_string_to_list (v
);
2066 long *data
= (long *) SCM_VELTS (v
);
2067 register unsigned long mask
;
2068 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2069 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2070 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2071 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2072 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2075 case scm_tc7_uvect
: {
2076 long *data
= (long *)SCM_VELTS(v
);
2077 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2078 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2081 case scm_tc7_ivect
: {
2082 long *data
= (long *)SCM_VELTS(v
);
2083 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2084 res
= scm_cons(scm_long2num(data
[k
]), res
);
2087 case scm_tc7_svect
: {
2089 data
= (short *)SCM_VELTS(v
);
2090 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2091 res
= scm_cons(SCM_MAKINUM (data
[k
]), res
);
2094 #ifdef HAVE_LONG_LONGS
2095 case scm_tc7_llvect
: {
2097 data
= (long_long
*)SCM_VELTS(v
);
2098 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2099 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2107 float *data
= (float *) SCM_VELTS (v
);
2108 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2109 res
= scm_cons (scm_make_real (data
[k
]), res
);
2114 double *data
= (double *) 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
)[2] = (double (*)[2]) SCM_VELTS (v
);
2122 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2123 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2131 static char s_bad_ralst
[] = "Bad scm_array contents list";
2133 static int l2ra(SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
);
2135 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2136 (SCM ndim
, SCM prot
, SCM lst
),
2137 "@deffnx procedure list->uniform-vector prot lst\n"
2138 "Returns a uniform array of the type indicated by prototype @var{prot}\n"
2139 "with elements the same as those of @var{lst}. Elements must be of the\n"
2140 "appropriate type, no coercions are done.")
2141 #define FUNC_NAME s_scm_list_to_uniform_array
2148 SCM_VALIDATE_INUM_COPY (1,ndim
,k
);
2151 n
= scm_ilength (row
);
2152 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2153 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2155 row
= SCM_CAR (row
);
2157 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2159 if (SCM_NULLP (shp
))
2162 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2163 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2166 if (!SCM_ARRAYP (ra
))
2168 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2169 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2170 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2173 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2176 badlst
:scm_wta (lst
, s_bad_ralst
, FUNC_NAME
);
2182 l2ra (SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
)
2184 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2185 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2188 return (SCM_NULLP (lst
));
2189 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2193 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2195 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2197 lst
= SCM_CDR (lst
);
2199 if (SCM_NNULLP (lst
))
2206 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2208 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2210 lst
= SCM_CDR (lst
);
2212 if (SCM_NNULLP (lst
))
2220 rapr1 (SCM ra
,scm_sizet j
,scm_sizet k
,SCM port
,scm_print_state
*pstate
)
2223 long n
= SCM_INUM (scm_uniform_vector_length (ra
));
2226 switch SCM_TYP7 (ra
)
2231 SCM_ARRAY_BASE (ra
) = j
;
2233 scm_iprin1 (ra
, port
, pstate
);
2234 for (j
+= inc
; n
-- > 0; j
+= inc
)
2236 scm_putc (' ', port
);
2237 SCM_ARRAY_BASE (ra
) = j
;
2238 scm_iprin1 (ra
, port
, pstate
);
2242 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2245 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2246 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2248 scm_putc ('(', port
);
2249 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2250 scm_puts (") ", port
);
2253 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2254 { /* could be zero size. */
2255 scm_putc ('(', port
);
2256 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2257 scm_putc (')', port
);
2263 { /* Could be zero-dimensional */
2264 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2265 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2269 ra
= SCM_ARRAY_V (ra
);
2272 /* scm_tc7_bvect and scm_tc7_llvect only? */
2274 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2275 for (j
+= inc
; n
-- > 0; j
+= inc
)
2277 scm_putc (' ', port
);
2278 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2281 case scm_tc7_string
:
2283 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2284 if (SCM_WRITINGP (pstate
))
2285 for (j
+= inc
; n
-- > 0; j
+= inc
)
2287 scm_putc (' ', port
);
2288 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2291 for (j
+= inc
; n
-- > 0; j
+= inc
)
2292 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2294 case scm_tc7_byvect
:
2296 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2297 for (j
+= inc
; n
-- > 0; j
+= inc
)
2299 scm_putc (' ', port
);
2300 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2310 /* intprint can't handle >= 2^31. */
2311 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2312 scm_puts (str
, port
);
2314 for (j
+= inc
; n
-- > 0; j
+= inc
)
2316 scm_putc (' ', port
);
2317 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2318 scm_puts (str
, port
);
2323 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2324 for (j
+= inc
; n
-- > 0; j
+= inc
)
2326 scm_putc (' ', port
);
2327 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2333 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2334 for (j
+= inc
; n
-- > 0; j
+= inc
)
2336 scm_putc (' ', port
);
2337 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2344 SCM z
= scm_make_real (1.0);
2345 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2346 scm_print_real (z
, port
, pstate
);
2347 for (j
+= inc
; n
-- > 0; j
+= inc
)
2349 scm_putc (' ', port
);
2350 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2351 scm_print_real (z
, port
, pstate
);
2358 SCM z
= scm_make_real (1.0 / 3.0);
2359 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2360 scm_print_real (z
, port
, pstate
);
2361 for (j
+= inc
; n
-- > 0; j
+= inc
)
2363 scm_putc (' ', port
);
2364 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2365 scm_print_real (z
, port
, pstate
);
2372 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2373 SCM_REAL_VALUE (z
) =
2374 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2375 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2376 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2378 for (j
+= inc
; n
-- > 0; j
+= inc
)
2380 scm_putc (' ', port
);
2382 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2383 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2384 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2395 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2399 scm_putc ('#', port
);
2405 long ndim
= SCM_ARRAY_NDIM (v
);
2406 base
= SCM_ARRAY_BASE (v
);
2407 v
= SCM_ARRAY_V (v
);
2411 scm_puts ("<enclosed-array ", port
);
2412 rapr1 (exp
, base
, 0, port
, pstate
);
2413 scm_putc ('>', port
);
2418 scm_intprint (ndim
, 10, port
);
2423 if (SCM_EQ_P (exp
, v
))
2424 { /* a uve, not an scm_array */
2425 register long i
, j
, w
;
2426 scm_putc ('*', port
);
2427 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2429 scm_bits_t w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2430 for (j
= SCM_LONG_BIT
; j
; j
--)
2432 scm_putc (w
& 1 ? '1' : '0', port
);
2436 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2439 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2442 scm_putc (w
& 1 ? '1' : '0', port
);
2449 scm_putc ('b', port
);
2451 case scm_tc7_string
:
2452 scm_putc ('a', port
);
2454 case scm_tc7_byvect
:
2455 scm_putc ('y', port
);
2458 scm_putc ('u', port
);
2461 scm_putc ('e', port
);
2464 scm_putc ('h', port
);
2466 #ifdef HAVE_LONG_LONGS
2467 case scm_tc7_llvect
:
2468 scm_putc ('l', port
);
2472 scm_putc ('s', port
);
2475 scm_putc ('i', port
);
2478 scm_putc ('c', port
);
2481 scm_putc ('(', port
);
2482 rapr1 (exp
, base
, 0, port
, pstate
);
2483 scm_putc (')', port
);
2487 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2489 "Returns an object that would produce an array of the same type as\n"
2490 "@var{array}, if used as the @var{prototype} for\n"
2491 "@code{make-uniform-array}.")
2492 #define FUNC_NAME s_scm_array_prototype
2495 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2497 switch SCM_TYP7 (ra
)
2500 badarg
:SCM_WTA (1,ra
);
2502 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2504 return SCM_UNSPECIFIED
;
2505 ra
= SCM_ARRAY_V (ra
);
2507 case scm_tc7_vector
:
2512 case scm_tc7_string
:
2513 return SCM_MAKE_CHAR ('a');
2514 case scm_tc7_byvect
:
2515 return SCM_MAKE_CHAR ('\0');
2517 return SCM_MAKINUM (1L);
2519 return SCM_MAKINUM (-1L);
2521 return SCM_CDR (scm_intern ("s", 1));
2522 #ifdef HAVE_LONG_LONGS
2523 case scm_tc7_llvect
:
2524 return SCM_CDR (scm_intern ("l", 1));
2527 return scm_make_real (1.0);
2529 return scm_make_real (1.0 / 3.0);
2531 return scm_make_complex (0.0, 1.0);
2540 return SCM_ARRAY_V (ptr
);
2547 scm_must_free (SCM_ARRAY_MEM (ptr
));
2548 return sizeof (scm_array
) + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_array_dim
);
2554 scm_tc16_array
= scm_make_smob_type_mfpe ("array", 0,
2559 scm_add_feature ("array");
2560 #ifndef SCM_MAGIC_SNARFER
2561 #include "libguile/unif.x"