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
)
159 if (SCM_TRUE_P (prot
))
161 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
162 type
= scm_tc7_bvect
;
164 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
166 i
= sizeof (char) * k
;
167 type
= scm_tc7_byvect
;
169 else if (SCM_CHARP (prot
))
171 i
= sizeof (char) * k
;
172 type
= scm_tc7_string
;
174 else if (SCM_INUMP (prot
))
176 i
= sizeof (long) * k
;
177 if (SCM_INUM (prot
) > 0)
178 type
= scm_tc7_uvect
;
180 type
= scm_tc7_ivect
;
182 else if (SCM_SYMBOLP (prot
) && (1 == SCM_LENGTH (prot
)))
186 s
= SCM_CHARS (prot
)[0];
189 i
= sizeof (short) * k
;
190 type
= scm_tc7_svect
;
192 #ifdef HAVE_LONG_LONGS
195 i
= sizeof (long_long
) * k
;
196 type
= scm_tc7_llvect
;
201 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
205 if (SCM_IMP (prot
) || !SCM_INEXACTP (prot
))
206 /* Huge non-unif vectors are NOT supported. */
207 /* no special scm_vector */
208 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
209 else if (singp (prot
))
211 i
= sizeof (float) * k
;
212 type
= scm_tc7_fvect
;
214 else if (SCM_COMPLEXP (prot
))
216 i
= 2 * sizeof (double) * k
;
217 type
= scm_tc7_cvect
;
221 i
= sizeof (double) * k
;
222 type
= scm_tc7_dvect
;
227 SCM_SETCHARS (v
, (char *) scm_must_malloc (i
? i
: 1, "vector"));
228 SCM_SETLENGTH (v
, (k
< SCM_LENGTH_MAX
? k
: SCM_LENGTH_MAX
), type
);
233 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
235 "Returns the number of elements in @var{uve}.")
236 #define FUNC_NAME s_scm_uniform_vector_length
238 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
243 badarg1
:SCM_WTA(1,v
);
255 #ifdef HAVE_LONG_LONGS
258 return SCM_MAKINUM (SCM_LENGTH (v
));
263 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
265 "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n"
266 "The @var{prototype} argument is used with uniform arrays and is described\n"
268 #define FUNC_NAME s_scm_array_p
272 nprot
= SCM_UNBNDP (prot
);
277 while (SCM_TYP7 (v
) == scm_tc7_smob
)
288 return SCM_BOOL(nprot
);
293 switch (SCM_TYP7 (v
))
296 protp
= (SCM_TRUE_P (prot
));
298 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
300 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
302 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
304 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
307 protp
= SCM_SYMBOLP (prot
)
308 && (1 == SCM_LENGTH (prot
))
309 && ('s' == SCM_CHARS (prot
)[0]);
310 #ifdef HAVE_LONG_LONGS
312 protp
= SCM_SYMBOLP (prot
)
313 && (1 == SCM_LENGTH (prot
))
314 && ('s' == SCM_CHARS (prot
)[0]);
317 protp
= singp (prot
);
319 protp
= SCM_REALP(prot
);
321 protp
= SCM_COMPLEXP(prot
);
324 protp
= SCM_NULLP(prot
);
329 return SCM_BOOL(protp
);
335 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
337 "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n"
338 "array, @code{0} is returned.")
339 #define FUNC_NAME s_scm_array_rank
343 switch (SCM_TYP7 (ra
))
356 #ifdef HAVE_LONG_LONGS
360 return SCM_MAKINUM (1L);
363 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
370 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
372 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
373 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
375 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
377 #define FUNC_NAME s_scm_array_dimensions
384 switch (SCM_TYP7 (ra
))
399 #ifdef HAVE_LONG_LONGS
402 return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra
)), SCM_EOL
);
404 if (!SCM_ARRAYP (ra
))
406 k
= SCM_ARRAY_NDIM (ra
);
407 s
= SCM_ARRAY_DIMS (ra
);
409 res
= scm_cons (s
[k
].lbnd
410 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
411 SCM_MAKINUM (s
[k
].ubnd
),
413 : SCM_MAKINUM (1 + s
[k
].ubnd
),
421 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
423 "Return the root vector of a shared array.")
424 #define FUNC_NAME s_scm_shared_array_root
426 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
427 return SCM_ARRAY_V (ra
);
432 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
434 "Return the root vector index of the first element in the array.")
435 #define FUNC_NAME s_scm_shared_array_offset
437 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
438 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
443 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
445 "For each dimension, return the distance between elements in the root vector.")
446 #define FUNC_NAME s_scm_shared_array_increments
451 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
452 k
= SCM_ARRAY_NDIM (ra
);
453 s
= SCM_ARRAY_DIMS (ra
);
455 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
461 static char s_bad_ind
[] = "Bad scm_array index";
465 scm_aind (SCM ra
, SCM args
, const char *what
)
469 register scm_sizet pos
= SCM_ARRAY_BASE (ra
);
470 register scm_sizet k
= SCM_ARRAY_NDIM (ra
);
471 scm_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
472 if (SCM_INUMP (args
))
474 SCM_ASSERT (1 == k
, scm_makfrom0str (what
), SCM_WNA
, NULL
);
475 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
477 while (k
&& SCM_NIMP (args
))
479 ind
= SCM_CAR (args
);
480 args
= SCM_CDR (args
);
481 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, what
);
483 SCM_ASSERT (j
>= (s
->lbnd
) && j
<= (s
->ubnd
), ind
, SCM_OUTOFRANGE
, what
);
484 pos
+= (j
- s
->lbnd
) * (s
->inc
);
488 SCM_ASSERT (0 == k
&& SCM_NULLP (args
), scm_makfrom0str (what
), SCM_WNA
,
496 scm_make_ra (int ndim
)
501 SCM_NEWSMOB(ra
, ((long) ndim
<< 17) + scm_tc16_array
,
502 scm_must_malloc ((long) (sizeof (scm_array
) + ndim
* sizeof (scm_array_dim
)),
504 SCM_ARRAY_V (ra
) = scm_nullvect
;
509 static char s_bad_spec
[] = "Bad scm_array dimension";
510 /* Increments will still need to be set. */
514 scm_shap2ra (SCM args
, const char *what
)
518 int ndim
= scm_ilength (args
);
519 SCM_ASSERT (0 <= ndim
, args
, s_bad_spec
, what
);
520 ra
= scm_make_ra (ndim
);
521 SCM_ARRAY_BASE (ra
) = 0;
522 s
= SCM_ARRAY_DIMS (ra
);
523 for (; SCM_NIMP (args
); s
++, args
= SCM_CDR (args
))
525 spec
= SCM_CAR (args
);
529 SCM_ASSERT (SCM_INUMP (spec
) && SCM_INUM (spec
) >= 0, spec
,
532 s
->ubnd
= SCM_INUM (spec
) - 1;
537 SCM_ASSERT (SCM_CONSP (spec
) && SCM_INUMP (SCM_CAR (spec
)), spec
,
539 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
541 SCM_ASSERT (SCM_CONSP (sp
)
542 && SCM_INUMP (SCM_CAR (sp
)) && SCM_NULLP (SCM_CDR (sp
)),
543 spec
, s_bad_spec
, what
);
544 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
551 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
552 (SCM dims
, SCM prot
, SCM fill
),
553 "@deffnx primitive make-uniform-vector length prototype [fill]\n"
554 "Creates and returns a uniform array or vector of type corresponding to\n"
555 "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n"
556 "@var{fill} is supplied, it's used to fill the array, otherwise \n"
557 "@var{prototype} is used.")
558 #define FUNC_NAME s_scm_dimensions_to_uniform_array
560 scm_sizet k
, vlen
= 1;
564 if (SCM_INUMP (dims
))
566 if (SCM_INUM (dims
) < SCM_LENGTH_MAX
)
568 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
570 if (!SCM_UNBNDP (fill
))
571 scm_array_fill_x (answer
, fill
);
572 else if (SCM_SYMBOLP (prot
))
573 scm_array_fill_x (answer
, SCM_MAKINUM (0));
575 scm_array_fill_x (answer
, prot
);
579 dims
= scm_cons (dims
, SCM_EOL
);
581 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
582 dims
, SCM_ARG1
, FUNC_NAME
);
583 ra
= scm_shap2ra (dims
, FUNC_NAME
);
584 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
585 s
= SCM_ARRAY_DIMS (ra
);
586 k
= SCM_ARRAY_NDIM (ra
);
589 s
[k
].inc
= (rlen
> 0 ? rlen
: 0);
590 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
591 vlen
*= (s
[k
].ubnd
- s
[k
].lbnd
+ 1);
593 if (rlen
< SCM_LENGTH_MAX
)
594 SCM_ARRAY_V (ra
) = scm_make_uve ((rlen
> 0 ? rlen
: 0L), prot
);
598 switch (SCM_TYP7 (scm_make_uve (0L, prot
)))
610 bit
= sizeof (float) * SCM_CHAR_BIT
/ sizeof (char);
613 bit
= sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
616 bit
= 2 * sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
619 SCM_ARRAY_BASE (ra
) = (SCM_LONG_BIT
+ bit
- 1) / bit
;
620 rlen
+= SCM_ARRAY_BASE (ra
);
621 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
622 *((long *) SCM_VELTS (SCM_ARRAY_V (ra
))) = rlen
;
624 if (!SCM_UNBNDP (fill
))
626 scm_array_fill_x (ra
, fill
);
628 else if (SCM_SYMBOLP (prot
))
629 scm_array_fill_x (ra
, SCM_MAKINUM (0));
631 scm_array_fill_x (ra
, prot
);
632 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
633 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
634 return SCM_ARRAY_V (ra
);
641 scm_ra_set_contp (SCM ra
)
643 scm_sizet k
= SCM_ARRAY_NDIM (ra
);
646 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
649 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
651 SCM_SETAND_CAR (ra
, ~SCM_ARRAY_CONTIGUOUS
);
654 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
655 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
658 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
662 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
663 (SCM oldra
, SCM mapfunc
, SCM dims
),
664 "@code{make-shared-array} can be used to create shared subarrays of other\n"
665 "arrays. The @var{mapper} is a function that translates coordinates in\n"
666 "the new array into coordinates in the old array. A @var{mapper} must be\n"
667 "linear, and its range must stay within the bounds of the old array, but\n"
668 "it can be otherwise arbitrary. A simple example:\n"
670 "(define fred (make-array #f 8 8))\n"
671 "(define freds-diagonal\n"
672 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
673 "(array-set! freds-diagonal 'foo 3)\n"
674 "(array-ref fred 3 3) @result{} foo\n"
675 "(define freds-center\n"
676 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
677 "(array-ref freds-center 0 0) @result{} foo\n"
679 #define FUNC_NAME s_scm_make_shared_array
685 long old_min
, new_min
, old_max
, new_max
;
687 SCM_VALIDATE_ARRAY (1,oldra
);
688 SCM_VALIDATE_PROC (2,mapfunc
);
689 ra
= scm_shap2ra (dims
, FUNC_NAME
);
690 if (SCM_ARRAYP (oldra
))
692 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
693 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
694 s
= SCM_ARRAY_DIMS (oldra
);
695 k
= SCM_ARRAY_NDIM (oldra
);
699 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
701 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
706 SCM_ARRAY_V (ra
) = oldra
;
708 old_max
= (long) SCM_LENGTH (oldra
) - 1;
711 s
= SCM_ARRAY_DIMS (ra
);
712 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
714 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
715 if (s
[k
].ubnd
< s
[k
].lbnd
)
717 if (1 == SCM_ARRAY_NDIM (ra
))
718 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
720 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
724 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
725 if (SCM_ARRAYP (oldra
))
726 i
= (scm_sizet
) scm_aind (oldra
, imap
, FUNC_NAME
);
729 if (SCM_NINUMP (imap
))
732 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
733 imap
, s_bad_ind
, FUNC_NAME
);
734 imap
= SCM_CAR (imap
);
738 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
740 k
= SCM_ARRAY_NDIM (ra
);
743 if (s
[k
].ubnd
> s
[k
].lbnd
)
745 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
746 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
747 if (SCM_ARRAYP (oldra
))
749 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
752 if (SCM_NINUMP (imap
))
755 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
756 imap
, s_bad_ind
, FUNC_NAME
);
757 imap
= SCM_CAR (imap
);
759 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
763 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
765 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
768 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
769 indptr
= SCM_CDR (indptr
);
771 SCM_ASSERT (old_min
<= new_min
&& old_max
>= new_max
, SCM_UNDEFINED
,
772 "mapping out of range", FUNC_NAME
);
773 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
775 if (1 == s
->inc
&& 0 == s
->lbnd
776 && SCM_LENGTH (SCM_ARRAY_V (ra
)) == 1 + s
->ubnd
)
777 return SCM_ARRAY_V (ra
);
778 if (s
->ubnd
< s
->lbnd
)
779 return scm_make_uve (0L, scm_array_prototype (ra
));
781 scm_ra_set_contp (ra
);
787 /* args are RA . DIMS */
788 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
790 "Returns an array sharing contents with @var{array}, but with dimensions\n"
791 "arranged in a different order. There must be one @var{dim} argument for\n"
792 "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n"
793 "be integers between 0 and the rank of the array to be returned. Each\n"
794 "integer in that range must appear at least once in the argument list.\n\n"
795 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n"
796 "in the array to be returned, their positions in the argument list to\n"
797 "dimensions of @var{array}. Several @var{dim}s may have the same value,\n"
798 "in which case the returned array will have smaller rank than\n"
802 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
803 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
804 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
805 " #2((a 4) (b 5) (c 6))\n"
807 #define FUNC_NAME s_scm_transpose_array
809 SCM res
, vargs
, *ve
= &vargs
;
810 scm_array_dim
*s
, *r
;
813 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
814 switch (SCM_TYP7 (ra
))
817 badarg
:SCM_WTA (1,ra
);
827 #ifdef HAVE_LONG_LONGS
830 SCM_ASSERT (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
831 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
832 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), SCM_CAR (args
), SCM_ARG2
,
834 SCM_ASSERT (SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)), SCM_CAR (args
), SCM_OUTOFRANGE
,
838 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
839 vargs
= scm_vector (args
);
840 SCM_ASSERT (SCM_LENGTH (vargs
) == SCM_ARRAY_NDIM (ra
),
841 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
842 ve
= SCM_VELTS (vargs
);
844 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
846 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
848 i
= SCM_INUM (ve
[k
]);
849 SCM_ASSERT (i
>= 0 && i
< SCM_ARRAY_NDIM (ra
), ve
[k
],
850 SCM_OUTOFRANGE
, FUNC_NAME
);
855 res
= scm_make_ra (ndim
);
856 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
857 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
860 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
861 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
863 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
865 i
= SCM_INUM (ve
[k
]);
866 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
867 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
868 if (r
->ubnd
< r
->lbnd
)
877 if (r
->ubnd
> s
->ubnd
)
879 if (r
->lbnd
< s
->lbnd
)
881 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
887 SCM_ASSERT (ndim
<= 0, args
, "bad argument list", FUNC_NAME
);
888 scm_ra_set_contp (res
);
894 /* args are RA . AXES */
895 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
897 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
898 "the rank of @var{array}. @var{enclose-array} returns an array\n"
899 "resembling an array of shared arrays. The dimensions of each shared\n"
900 "array are the same as the @var{dim}th dimensions of the original array,\n"
901 "the dimensions of the outer array are the same as those of the original\n"
902 "array that did not match a @var{dim}.\n\n"
903 "An enclosed array is not a general Scheme array. Its elements may not\n"
904 "be set using @code{array-set!}. Two references to the same element of\n"
905 "an enclosed array will be @code{equal?} but will not in general be\n"
906 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
907 "enclosed array is unspecified.\n\n"
910 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
911 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
912 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
913 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
915 #define FUNC_NAME s_scm_enclose_array
917 SCM axv
, res
, ra_inr
;
918 scm_array_dim vdim
, *s
= &vdim
;
919 int ndim
, j
, k
, ninr
, noutr
;
921 if (SCM_NULLP (axes
))
922 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
923 ninr
= scm_ilength (axes
);
924 SCM_ASSERT (0 <= ninr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
925 ra_inr
= scm_make_ra (ninr
);
926 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
931 badarg1
:SCM_WTA (1,ra
);
943 #ifdef HAVE_LONG_LONGS
947 s
->ubnd
= SCM_LENGTH (ra
) - 1;
949 SCM_ARRAY_V (ra_inr
) = ra
;
950 SCM_ARRAY_BASE (ra_inr
) = 0;
954 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
955 s
= SCM_ARRAY_DIMS (ra
);
956 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
957 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
958 ndim
= SCM_ARRAY_NDIM (ra
);
962 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
963 SCM_ASSERT (0 <= noutr
, scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
964 res
= scm_make_ra (noutr
);
965 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
966 SCM_ARRAY_V (res
) = ra_inr
;
967 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
969 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes
)), SCM_CAR (axes
), "bad axis", FUNC_NAME
);
970 j
= SCM_INUM (SCM_CAR (axes
));
971 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
972 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
973 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
974 SCM_CHARS (axv
)[j
] = 1;
976 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
978 while (SCM_CHARS (axv
)[j
])
980 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
981 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
982 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
984 scm_ra_set_contp (ra_inr
);
985 scm_ra_set_contp (res
);
992 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
994 "Returns @code{#t} if its arguments would be acceptable to array-ref.")
995 #define FUNC_NAME s_scm_array_in_bounds_p
999 register scm_sizet k
;
1003 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1004 if (SCM_NIMP (args
))
1007 ind
= SCM_CAR (args
);
1008 args
= SCM_CDR (args
);
1009 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
1010 pos
= SCM_INUM (ind
);
1017 badarg1
:SCM_WTA (1,v
);
1018 wna
: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME
));
1020 k
= SCM_ARRAY_NDIM (v
);
1021 s
= SCM_ARRAY_DIMS (v
);
1022 pos
= SCM_ARRAY_BASE (v
);
1025 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1032 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1034 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1037 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1038 if (!(--k
&& SCM_NIMP (args
)))
1040 ind
= SCM_CAR (args
);
1041 args
= SCM_CDR (args
);
1043 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, FUNC_NAME
);
1045 SCM_ASRTGO (0 == k
, wna
);
1046 v
= SCM_ARRAY_V (v
);
1049 case scm_tc7_string
:
1050 case scm_tc7_byvect
:
1057 #ifdef HAVE_LONG_LONGS
1058 case scm_tc7_llvect
:
1060 case scm_tc7_vector
:
1062 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1063 return SCM_BOOL(pos
>= 0 && pos
< SCM_LENGTH (v
));
1069 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1072 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1074 "Returns the element at the @code{(index1, index2)} element in @var{array}.")
1075 #define FUNC_NAME s_scm_uniform_vector_ref
1081 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1084 else if (SCM_ARRAYP (v
))
1086 pos
= scm_aind (v
, args
, FUNC_NAME
);
1087 v
= SCM_ARRAY_V (v
);
1091 if (SCM_NIMP (args
))
1094 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1095 pos
= SCM_INUM (SCM_CAR (args
));
1096 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1100 SCM_VALIDATE_INUM (2,args
);
1101 pos
= SCM_INUM (args
);
1103 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1109 if (SCM_NULLP (args
))
1116 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1118 scm_wrong_num_args (SCM_FUNC_NAME
);
1121 int k
= SCM_ARRAY_NDIM (v
);
1122 SCM res
= scm_make_ra (k
);
1123 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1124 SCM_ARRAY_BASE (res
) = pos
;
1127 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1128 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1129 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1134 if (SCM_BITVEC_REF (v
, pos
))
1138 case scm_tc7_string
:
1139 return SCM_MAKE_CHAR (SCM_UCHARS (v
)[pos
]);
1140 case scm_tc7_byvect
:
1141 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1143 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1145 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1148 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1149 #ifdef HAVE_LONG_LONGS
1150 case scm_tc7_llvect
:
1151 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1155 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1157 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1159 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1160 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1161 case scm_tc7_vector
:
1163 return SCM_VELTS (v
)[pos
];
1168 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1169 tries to recycle conses. (Make *sure* you want them recycled.) */
1172 scm_cvref (SCM v
, scm_sizet pos
, SCM last
)
1177 scm_wta (v
, (char *) SCM_ARG1
, "PROGRAMMING ERROR: scm_cvref");
1179 if (SCM_BITVEC_REF(v
,pos
))
1183 case scm_tc7_string
:
1184 return SCM_MAKE_CHAR (SCM_UCHARS (v
)[pos
]);
1185 case scm_tc7_byvect
:
1186 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1188 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1190 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1192 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1193 #ifdef HAVE_LONG_LONGS
1194 case scm_tc7_llvect
:
1195 return scm_long_long2num (((long_long
*) SCM_CELL_WORD_1 (v
))[pos
]);
1198 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1200 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1203 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1205 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1207 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1210 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1212 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1214 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1215 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1218 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1219 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1220 case scm_tc7_vector
:
1222 return SCM_VELTS (v
)[pos
];
1224 { /* enclosed scm_array */
1225 int k
= SCM_ARRAY_NDIM (v
);
1226 SCM res
= scm_make_ra (k
);
1227 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1228 SCM_ARRAY_BASE (res
) = pos
;
1231 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1232 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1233 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1240 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1243 /* Note that args may be a list or an immediate object, depending which
1244 PROC is used (and it's called from C too). */
1245 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1246 (SCM v
, SCM obj
, SCM args
),
1247 "Sets the element at the @code{(index1, index2)} element in @var{array} to\n"
1248 "@var{new-value}. The value returned by array-set! is unspecified.")
1249 #define FUNC_NAME s_scm_array_set_x
1252 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1255 pos
= scm_aind (v
, args
, FUNC_NAME
);
1256 v
= SCM_ARRAY_V (v
);
1260 if (SCM_NIMP (args
))
1262 SCM_ASSERT (SCM_CONSP(args
) && SCM_INUMP (SCM_CAR (args
)), args
,
1263 SCM_ARG3
, FUNC_NAME
);
1264 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1265 pos
= SCM_INUM (SCM_CAR (args
));
1269 SCM_VALIDATE_INUM_COPY (3,args
,pos
);
1271 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1273 switch (SCM_TYP7 (v
))
1279 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1281 scm_wrong_num_args (SCM_FUNC_NAME
);
1282 case scm_tc7_smob
: /* enclosed */
1285 if (SCM_FALSEP (obj
))
1286 SCM_BITVEC_CLR(v
,pos
);
1287 else if (SCM_TRUE_P (obj
))
1288 SCM_BITVEC_SET(v
,pos
);
1290 badobj
:SCM_WTA (2,obj
);
1292 case scm_tc7_string
:
1293 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1294 SCM_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1296 case scm_tc7_byvect
:
1297 if (SCM_CHARP (obj
))
1298 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1299 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1300 ((char *)SCM_CHARS (v
))[pos
] = SCM_INUM (obj
);
1303 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2ulong(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1306 SCM_VELTS(v
)[pos
] = SCM_PACK (scm_num2long(obj
, (char *)SCM_ARG2
, FUNC_NAME
));
1309 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1310 ((short *) SCM_CELL_WORD_1 (v
))[pos
] = SCM_INUM (obj
);
1312 #ifdef HAVE_LONG_LONGS
1313 case scm_tc7_llvect
:
1314 ((long_long
*) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2long_long (obj
, (char *)SCM_ARG2
, FUNC_NAME
);
1320 ((float *) SCM_CELL_WORD_1 (v
))[pos
] = (float) scm_num2dbl (obj
, FUNC_NAME
);
1323 ((double *) SCM_CELL_WORD_1 (v
))[pos
] = scm_num2dbl (obj
, FUNC_NAME
);
1326 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1327 if (SCM_REALP (obj
)) {
1328 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1329 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = 0.0;
1331 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1332 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1335 case scm_tc7_vector
:
1337 SCM_VELTS (v
)[pos
] = obj
;
1340 return SCM_UNSPECIFIED
;
1344 /* attempts to unroll an array into a one-dimensional array.
1345 returns the unrolled array or #f if it can't be done. */
1346 /* if strict is not SCM_UNDEFINED, return #f if returned array
1347 wouldn't have contiguous elements. */
1348 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1349 (SCM ra
, SCM strict
),
1350 "@deffnx primitive array-contents array strict\n"
1351 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1352 "without changing their order (last subscript changing fastest), then\n"
1353 "@code{array-contents} returns that shared array, otherwise it returns\n"
1354 "@code{#f}. All arrays made by @var{make-array} and\n"
1355 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1356 "@var{make-shared-array} may not be.\n\n"
1357 "If the optional argument @var{strict} is provided, a shared array will\n"
1358 "be returned only if its elements are stored internally contiguous in\n"
1360 #define FUNC_NAME s_scm_array_contents
1365 switch SCM_TYP7 (ra
)
1369 case scm_tc7_vector
:
1371 case scm_tc7_string
:
1373 case scm_tc7_byvect
:
1380 #ifdef HAVE_LONG_LONGS
1381 case scm_tc7_llvect
:
1386 scm_sizet k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1387 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1389 for (k
= 0; k
< ndim
; k
++)
1390 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1391 if (!SCM_UNBNDP (strict
))
1393 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1395 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1397 if (len
!= SCM_LENGTH (SCM_ARRAY_V (ra
)) ||
1398 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1403 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
))) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1404 return SCM_ARRAY_V (ra
);
1405 sra
= scm_make_ra (1);
1406 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1407 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1408 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1409 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1410 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1419 scm_ra2contig (SCM ra
, int copy
)
1423 scm_sizet k
, len
= 1;
1424 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1425 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1426 k
= SCM_ARRAY_NDIM (ra
);
1427 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1429 if (scm_tc7_bvect
!= SCM_TYP7 (ra
))
1431 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
)) &&
1432 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1433 0 == len
% SCM_LONG_BIT
))
1436 ret
= scm_make_ra (k
);
1437 SCM_ARRAY_BASE (ret
) = 0;
1440 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1441 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1442 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1443 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1445 SCM_ARRAY_V (ret
) = scm_make_uve ((inc
- 1), scm_array_prototype (ra
));
1447 scm_array_copy_x (ra
, ret
);
1453 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1454 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1455 "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1456 "Attempts to read all elements of @var{ura}, in lexicographic order, as\n"
1457 "binary objects from @var{port-or-fdes}.\n"
1458 "If an end of file is encountered during\n"
1459 "uniform-array-read! the objects up to that point only are put into @var{ura}\n"
1460 "(starting at the beginning) and the remainder of the array is\n"
1462 "The optional arguments @var{start} and @var{end} allow\n"
1463 "a specified region of a vector (or linearized array) to be read,\n"
1464 "leaving the remainder of the vector unchanged.\n\n"
1465 "@code{uniform-array-read!} returns the number of objects read.\n"
1466 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1467 "returned by @code{(current-input-port)}.")
1468 #define FUNC_NAME s_scm_uniform_array_read_x
1470 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1476 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1477 if (SCM_UNBNDP (port_or_fd
))
1478 port_or_fd
= scm_cur_inp
;
1480 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1481 || (SCM_OPINPORTP (port_or_fd
)),
1482 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1483 vlen
= SCM_LENGTH (v
);
1489 badarg1
:SCM_WTA (SCM_ARG1
,v
);
1491 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1492 cra
= scm_ra2contig (ra
, 0);
1493 cstart
+= SCM_ARRAY_BASE (cra
);
1494 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1495 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1496 v
= SCM_ARRAY_V (cra
);
1498 case scm_tc7_string
:
1499 case scm_tc7_byvect
:
1503 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1504 cstart
/= SCM_LONG_BIT
;
1510 sz
= sizeof (short);
1512 #ifdef HAVE_LONG_LONGS
1513 case scm_tc7_llvect
:
1514 sz
= sizeof (long_long
);
1518 sz
= sizeof (float);
1521 sz
= sizeof (double);
1524 sz
= 2 * sizeof (double);
1529 if (!SCM_UNBNDP (start
))
1532 SCM_NUM2LONG (3, start
);
1534 if (offset
< 0 || offset
>= cend
)
1535 scm_out_of_range (FUNC_NAME
, start
);
1537 if (!SCM_UNBNDP (end
))
1540 SCM_NUM2LONG (4, end
);
1542 if (tend
<= offset
|| tend
> cend
)
1543 scm_out_of_range (FUNC_NAME
, end
);
1548 if (SCM_NIMP (port_or_fd
))
1550 scm_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1551 int remaining
= (cend
- offset
) * sz
;
1552 char *dest
= SCM_CHARS (v
) + (cstart
+ offset
) * sz
;
1554 if (pt
->rw_active
== SCM_PORT_WRITE
)
1555 scm_flush (port_or_fd
);
1557 ans
= cend
- offset
;
1558 while (remaining
> 0)
1560 if (pt
->read_pos
< pt
->read_end
)
1562 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1565 memcpy (dest
, pt
->read_pos
, to_copy
);
1566 pt
->read_pos
+= to_copy
;
1567 remaining
-= to_copy
;
1572 if (scm_fill_input (port_or_fd
) == EOF
)
1574 if (remaining
% sz
!= 0)
1576 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1578 ans
-= remaining
/ sz
;
1585 pt
->rw_active
= SCM_PORT_READ
;
1587 else /* file descriptor. */
1589 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1590 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1591 (scm_sizet
) (sz
* (cend
- offset
))));
1595 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1596 ans
*= SCM_LONG_BIT
;
1598 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1599 scm_array_copy_x (cra
, ra
);
1601 return SCM_MAKINUM (ans
);
1605 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1606 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1607 "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1608 "Writes all elements of @var{ura} as binary objects to\n"
1609 "@var{port-or-fdes}.\n\n"
1610 "The optional arguments @var{start}\n"
1611 "and @var{end} allow\n"
1612 "a specified region of a vector (or linearized array) to be written.\n\n"
1613 "The number of objects actually written is returned. \n"
1614 "@var{port-or-fdes} may be\n"
1615 "omitted, in which case it defaults to the value returned by\n"
1616 "@code{(current-output-port)}.")
1617 #define FUNC_NAME s_scm_uniform_array_write
1624 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1626 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1627 if (SCM_UNBNDP (port_or_fd
))
1628 port_or_fd
= scm_cur_outp
;
1630 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1631 || (SCM_OPOUTPORTP (port_or_fd
)),
1632 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1633 vlen
= SCM_LENGTH (v
);
1639 badarg1
:SCM_WTA (1, v
);
1641 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1642 v
= scm_ra2contig (v
, 1);
1643 cstart
= SCM_ARRAY_BASE (v
);
1644 vlen
= SCM_ARRAY_DIMS (v
)->inc
1645 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1646 v
= SCM_ARRAY_V (v
);
1648 case scm_tc7_string
:
1649 case scm_tc7_byvect
:
1653 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1654 cstart
/= SCM_LONG_BIT
;
1660 sz
= sizeof (short);
1662 #ifdef HAVE_LONG_LONGS
1663 case scm_tc7_llvect
:
1664 sz
= sizeof (long_long
);
1668 sz
= sizeof (float);
1671 sz
= sizeof (double);
1674 sz
= 2 * sizeof (double);
1679 if (!SCM_UNBNDP (start
))
1682 SCM_NUM2LONG (3, start
);
1684 if (offset
< 0 || offset
>= cend
)
1685 scm_out_of_range (FUNC_NAME
, start
);
1687 if (!SCM_UNBNDP (end
))
1690 SCM_NUM2LONG (4, end
);
1692 if (tend
<= offset
|| tend
> cend
)
1693 scm_out_of_range (FUNC_NAME
, end
);
1698 if (SCM_NIMP (port_or_fd
))
1700 char *source
= SCM_CHARS (v
) + (cstart
+ offset
) * sz
;
1702 ans
= cend
- offset
;
1703 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1705 else /* file descriptor. */
1707 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1708 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1709 (scm_sizet
) (sz
* (cend
- offset
))));
1713 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1714 ans
*= SCM_LONG_BIT
;
1716 return SCM_MAKINUM (ans
);
1721 static char cnt_tab
[16] =
1722 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1724 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1725 (SCM item
, SCM seq
),
1726 "Returns the number occurrences of @var{bool} in @var{bv}.")
1727 #define FUNC_NAME s_scm_bit_count
1730 register unsigned long cnt
= 0;
1731 register unsigned long w
;
1732 SCM_VALIDATE_INUM (2,seq
);
1733 switch SCM_TYP7 (seq
)
1738 if (0 == SCM_LENGTH (seq
))
1740 i
= (SCM_LENGTH (seq
) - 1) / SCM_LONG_BIT
;
1741 w
= SCM_UNPACK (SCM_VELTS (seq
)[i
]);
1742 if (SCM_FALSEP (item
))
1744 w
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (seq
) - 1) % SCM_LONG_BIT
);
1748 cnt
+= cnt_tab
[w
& 0x0f];
1750 return SCM_MAKINUM (cnt
);
1751 w
= SCM_UNPACK (SCM_VELTS (seq
)[i
]);
1752 if (SCM_FALSEP (item
))
1760 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1761 (SCM item
, SCM v
, SCM k
),
1762 "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n"
1763 "which is at least @var{k}. If no @var{bool} occurs within the specified\n"
1764 "range @code{#f} is returned.")
1765 #define FUNC_NAME s_scm_bit_position
1767 long i
, lenw
, xbits
, pos
;
1768 register unsigned long w
;
1769 SCM_VALIDATE_NIM (2,v
);
1770 SCM_VALIDATE_INUM_COPY (3,k
,pos
);
1771 SCM_ASSERT ((pos
<= SCM_LENGTH (v
)) && (pos
>= 0),
1772 k
, SCM_OUTOFRANGE
, FUNC_NAME
);
1773 if (pos
== SCM_LENGTH (v
))
1780 if (0 == SCM_LENGTH (v
))
1781 return SCM_MAKINUM (-1L);
1782 lenw
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1783 i
= pos
/ SCM_LONG_BIT
;
1784 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1785 if (SCM_FALSEP (item
))
1787 xbits
= (pos
% SCM_LONG_BIT
);
1789 w
= ((w
>> xbits
) << xbits
);
1790 xbits
= SCM_LONG_BIT
- 1 - (SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1793 if (w
&& (i
== lenw
))
1794 w
= ((w
<< xbits
) >> xbits
);
1800 return SCM_MAKINUM (pos
);
1805 return SCM_MAKINUM (pos
+ 1);
1808 return SCM_MAKINUM (pos
+ 2);
1810 return SCM_MAKINUM (pos
+ 3);
1817 pos
+= SCM_LONG_BIT
;
1818 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1819 if (SCM_FALSEP (item
))
1828 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1829 (SCM v
, SCM kv
, SCM obj
),
1830 "If uve is a bit-vector @var{bv} and uve must be of the same length. If\n"
1831 "@var{bool} is @code{#t}, uve is OR'ed into @var{bv}; If @var{bool} is @code{#f}, the\n"
1832 "inversion of uve is AND'ed into @var{bv}.\n\n"
1833 "If uve is a unsigned integer vector all the elements of uve must be\n"
1834 "between 0 and the @code{LENGTH} of @var{bv}. The bits of @var{bv}\n"
1835 "corresponding to the indexes in uve are set to @var{bool}.\n\n"
1836 "The return value is unspecified.")
1837 #define FUNC_NAME s_scm_bit_set_star_x
1839 register long i
, k
, vlen
;
1840 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1841 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1842 switch SCM_TYP7 (kv
)
1845 badarg2
:SCM_WTA (2,kv
);
1850 badarg1
: SCM_WTA (1,v
);
1852 vlen
= SCM_LENGTH (v
);
1853 if (SCM_FALSEP (obj
))
1854 for (i
= SCM_LENGTH (kv
); i
;)
1856 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1857 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1858 SCM_BITVEC_CLR(v
,k
);
1860 else if (SCM_TRUE_P (obj
))
1861 for (i
= SCM_LENGTH (kv
); i
;)
1863 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1864 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1865 SCM_BITVEC_SET(v
,k
);
1868 badarg3
:SCM_WTA (3,obj
);
1872 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1873 if (SCM_FALSEP (obj
))
1874 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1875 SCM_UNPACK (SCM_VELTS (v
)[k
]) &= ~ SCM_UNPACK(SCM_VELTS (kv
)[k
]);
1876 else if (SCM_TRUE_P (obj
))
1877 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1878 SCM_UNPACK (SCM_VELTS (v
)[k
]) |= SCM_UNPACK (SCM_VELTS (kv
)[k
]);
1883 return SCM_UNSPECIFIED
;
1888 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1889 (SCM v
, SCM kv
, SCM obj
),
1892 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1894 "@var{bv} is not modified.")
1895 #define FUNC_NAME s_scm_bit_count_star
1897 register long i
, vlen
, count
= 0;
1898 register unsigned long k
;
1901 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1902 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1903 switch SCM_TYP7 (kv
)
1916 vlen
= SCM_LENGTH (v
);
1917 if (SCM_FALSEP (obj
))
1918 for (i
= SCM_LENGTH (kv
); i
;)
1920 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1921 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1922 if (!SCM_BITVEC_REF(v
,k
))
1925 else if (SCM_TRUE_P (obj
))
1926 for (i
= SCM_LENGTH (kv
); i
;)
1928 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1929 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1930 if (SCM_BITVEC_REF (v
,k
))
1934 badarg3
:SCM_WTA (3,obj
);
1938 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1939 if (0 == SCM_LENGTH (v
))
1941 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1942 fObj
= SCM_TRUE_P (obj
);
1943 i
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1944 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1945 k
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1949 count
+= cnt_tab
[k
& 0x0f];
1951 return SCM_MAKINUM (count
);
1953 /* urg. repetitive (see above.) */
1954 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
1957 return SCM_MAKINUM (count
);
1962 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1964 "Modifies @var{bv} by replacing each element with its negation.")
1965 #define FUNC_NAME s_scm_bit_invert_x
1968 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1974 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1975 SCM_UNPACK (SCM_VELTS (v
)[k
]) = ~SCM_UNPACK(SCM_VELTS (v
)[k
]);
1978 badarg1
:SCM_WTA (1,v
);
1980 return SCM_UNSPECIFIED
;
1986 scm_istr2bve (char *str
, long len
)
1988 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
1989 long *data
= (long *) SCM_VELTS (v
);
1990 register unsigned long mask
;
1993 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
1996 j
= len
- k
* SCM_LONG_BIT
;
1997 if (j
> SCM_LONG_BIT
)
1999 for (mask
= 1L; j
--; mask
<<= 1)
2017 ra2l (SCM ra
,scm_sizet base
,scm_sizet k
)
2019 register SCM res
= SCM_EOL
;
2020 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2021 register scm_sizet i
;
2022 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2024 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2025 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2030 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2038 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2045 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2047 "Returns a list consisting of all the elements, in order, of @var{array}.")
2048 #define FUNC_NAME s_scm_array_to_list
2052 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2057 badarg1
:SCM_WTA (1,v
);
2059 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2060 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2061 case scm_tc7_vector
:
2063 return scm_vector_to_list (v
);
2064 case scm_tc7_string
:
2065 return scm_string_to_list (v
);
2068 long *data
= (long *) SCM_VELTS (v
);
2069 register unsigned long mask
;
2070 for (k
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2071 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2072 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2073 for (mask
= 1L << ((SCM_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2074 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2077 case scm_tc7_uvect
: {
2078 long *data
= (long *)SCM_VELTS(v
);
2079 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2080 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2083 case scm_tc7_ivect
: {
2084 long *data
= (long *)SCM_VELTS(v
);
2085 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2086 res
= scm_cons(scm_long2num(data
[k
]), res
);
2089 case scm_tc7_svect
: {
2091 data
= (short *)SCM_VELTS(v
);
2092 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2093 res
= scm_cons(SCM_MAKINUM (data
[k
]), res
);
2096 #ifdef HAVE_LONG_LONGS
2097 case scm_tc7_llvect
: {
2099 data
= (long_long
*)SCM_VELTS(v
);
2100 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2101 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2109 float *data
= (float *) SCM_VELTS (v
);
2110 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2111 res
= scm_cons (scm_make_real (data
[k
]), res
);
2116 double *data
= (double *) SCM_VELTS (v
);
2117 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2118 res
= scm_cons (scm_make_real (data
[k
]), res
);
2123 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2124 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2125 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2133 static char s_bad_ralst
[] = "Bad scm_array contents list";
2135 static int l2ra(SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
);
2137 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2138 (SCM ndim
, SCM prot
, SCM lst
),
2139 "@deffnx procedure list->uniform-vector prot lst\n"
2140 "Returns a uniform array of the type indicated by prototype @var{prot}\n"
2141 "with elements the same as those of @var{lst}. Elements must be of the\n"
2142 "appropriate type, no coercions are done.")
2143 #define FUNC_NAME s_scm_list_to_uniform_array
2150 SCM_VALIDATE_INUM_COPY (1,ndim
,k
);
2153 n
= scm_ilength (row
);
2154 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2155 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2157 row
= SCM_CAR (row
);
2159 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2161 if (SCM_NULLP (shp
))
2164 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2165 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2168 if (!SCM_ARRAYP (ra
))
2170 for (k
= 0; k
< SCM_LENGTH (ra
); k
++, lst
= SCM_CDR (lst
))
2171 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2174 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2177 badlst
:scm_wta (lst
, s_bad_ralst
, FUNC_NAME
);
2183 l2ra (SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
)
2185 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2186 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2189 return (SCM_NULLP (lst
));
2190 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2194 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2196 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2198 lst
= SCM_CDR (lst
);
2200 if (SCM_NNULLP (lst
))
2207 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2209 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2211 lst
= SCM_CDR (lst
);
2213 if (SCM_NNULLP (lst
))
2221 rapr1 (SCM ra
,scm_sizet j
,scm_sizet k
,SCM port
,scm_print_state
*pstate
)
2224 long n
= SCM_LENGTH (ra
);
2227 switch SCM_TYP7 (ra
)
2232 SCM_ARRAY_BASE (ra
) = j
;
2234 scm_iprin1 (ra
, port
, pstate
);
2235 for (j
+= inc
; n
-- > 0; j
+= inc
)
2237 scm_putc (' ', port
);
2238 SCM_ARRAY_BASE (ra
) = j
;
2239 scm_iprin1 (ra
, port
, pstate
);
2243 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2246 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2247 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2249 scm_putc ('(', port
);
2250 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2251 scm_puts (") ", port
);
2254 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2255 { /* could be zero size. */
2256 scm_putc ('(', port
);
2257 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2258 scm_putc (')', port
);
2264 { /* Could be zero-dimensional */
2265 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2266 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2270 ra
= SCM_ARRAY_V (ra
);
2273 /* scm_tc7_bvect and scm_tc7_llvect only? */
2275 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2276 for (j
+= inc
; n
-- > 0; j
+= inc
)
2278 scm_putc (' ', port
);
2279 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2282 case scm_tc7_string
:
2284 scm_iprin1 (SCM_MAKE_CHAR (SCM_UCHARS (ra
)[j
]), port
, pstate
);
2285 if (SCM_WRITINGP (pstate
))
2286 for (j
+= inc
; n
-- > 0; j
+= inc
)
2288 scm_putc (' ', port
);
2289 scm_iprin1 (SCM_MAKE_CHAR (SCM_UCHARS (ra
)[j
]), port
, pstate
);
2292 for (j
+= inc
; n
-- > 0; j
+= inc
)
2293 scm_putc (SCM_CHARS (ra
)[j
], port
);
2295 case scm_tc7_byvect
:
2297 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2298 for (j
+= inc
; n
-- > 0; j
+= inc
)
2300 scm_putc (' ', port
);
2301 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2311 /* intprint can't handle >= 2^31. */
2312 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2313 scm_puts (str
, port
);
2315 for (j
+= inc
; n
-- > 0; j
+= inc
)
2317 scm_putc (' ', port
);
2318 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2319 scm_puts (str
, port
);
2324 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2325 for (j
+= inc
; n
-- > 0; j
+= inc
)
2327 scm_putc (' ', port
);
2328 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2334 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2335 for (j
+= inc
; n
-- > 0; j
+= inc
)
2337 scm_putc (' ', port
);
2338 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2345 SCM z
= scm_make_real (1.0);
2346 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2347 scm_print_real (z
, port
, pstate
);
2348 for (j
+= inc
; n
-- > 0; j
+= inc
)
2350 scm_putc (' ', port
);
2351 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2352 scm_print_real (z
, port
, pstate
);
2359 SCM z
= scm_make_real (1.0 / 3.0);
2360 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2361 scm_print_real (z
, port
, pstate
);
2362 for (j
+= inc
; n
-- > 0; j
+= inc
)
2364 scm_putc (' ', port
);
2365 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2366 scm_print_real (z
, port
, pstate
);
2373 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2374 SCM_REAL_VALUE (z
) =
2375 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2376 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2377 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2379 for (j
+= inc
; n
-- > 0; j
+= inc
)
2381 scm_putc (' ', port
);
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
),
2396 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2400 scm_putc ('#', port
);
2406 long ndim
= SCM_ARRAY_NDIM (v
);
2407 base
= SCM_ARRAY_BASE (v
);
2408 v
= SCM_ARRAY_V (v
);
2412 scm_puts ("<enclosed-array ", port
);
2413 rapr1 (exp
, base
, 0, port
, pstate
);
2414 scm_putc ('>', port
);
2419 scm_intprint (ndim
, 10, port
);
2424 if (SCM_EQ_P (exp
, v
))
2425 { /* a uve, not an scm_array */
2426 register long i
, j
, w
;
2427 scm_putc ('*', port
);
2428 for (i
= 0; i
< (SCM_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2430 scm_bits_t w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2431 for (j
= SCM_LONG_BIT
; j
; j
--)
2433 scm_putc (w
& 1 ? '1' : '0', port
);
2437 j
= SCM_LENGTH (exp
) % SCM_LONG_BIT
;
2440 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_LENGTH (exp
) / SCM_LONG_BIT
]);
2443 scm_putc (w
& 1 ? '1' : '0', port
);
2450 scm_putc ('b', port
);
2452 case scm_tc7_string
:
2453 scm_putc ('a', port
);
2455 case scm_tc7_byvect
:
2456 scm_putc ('y', port
);
2459 scm_putc ('u', port
);
2462 scm_putc ('e', port
);
2465 scm_putc ('h', port
);
2467 #ifdef HAVE_LONG_LONGS
2468 case scm_tc7_llvect
:
2469 scm_putc ('l', port
);
2473 scm_putc ('s', port
);
2476 scm_putc ('i', port
);
2479 scm_putc ('c', port
);
2482 scm_putc ('(', port
);
2483 rapr1 (exp
, base
, 0, port
, pstate
);
2484 scm_putc (')', port
);
2488 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2490 "Returns an object that would produce an array of the same type as\n"
2491 "@var{array}, if used as the @var{prototype} for\n"
2492 "@code{make-uniform-array}.")
2493 #define FUNC_NAME s_scm_array_prototype
2496 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2502 badarg
:SCM_WTA (1,ra
);
2504 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2506 return SCM_UNSPECIFIED
;
2507 ra
= SCM_ARRAY_V (ra
);
2509 case scm_tc7_vector
:
2514 case scm_tc7_string
:
2515 return SCM_MAKE_CHAR ('a');
2516 case scm_tc7_byvect
:
2517 return SCM_MAKE_CHAR ('\0');
2519 return SCM_MAKINUM (1L);
2521 return SCM_MAKINUM (-1L);
2523 return SCM_CDR (scm_intern ("s", 1));
2524 #ifdef HAVE_LONG_LONGS
2525 case scm_tc7_llvect
:
2526 return SCM_CDR (scm_intern ("l", 1));
2529 return scm_make_real (1.0);
2531 return scm_make_real (1.0 / 3.0);
2533 return scm_make_complex (0.0, 1.0);
2542 return SCM_ARRAY_V (ptr
);
2549 scm_must_free (SCM_CHARS (ptr
));
2550 return sizeof (scm_array
) + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_array_dim
);
2556 scm_tc16_array
= scm_make_smob_type_mfpe ("array", 0,
2561 scm_add_feature ("array");
2562 #include "libguile/unif.x"