1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
46 This file has code for arrays in lots of variants (double, integer,
47 unsigned etc. ). It suffers from hugely repetitive code because
48 there is similar (but different) code for every variant included. (urg.)
58 #include "libguile/_scm.h"
59 #include "libguile/chars.h"
60 #include "libguile/eval.h"
61 #include "libguile/fports.h"
62 #include "libguile/smob.h"
63 #include "libguile/strop.h"
64 #include "libguile/feature.h"
65 #include "libguile/root.h"
66 #include "libguile/strings.h"
67 #include "libguile/vectors.h"
69 #include "libguile/validate.h"
70 #include "libguile/unif.h"
71 #include "libguile/ramap.h"
78 /* The set of uniform scm_vector types is:
80 * unsigned char string
87 * complex double cvect
92 scm_t_bits scm_tc16_array
;
94 /* return the size of an element in a uniform array or 0 if type not
97 scm_uniform_element_size (SCM obj
)
101 switch (SCM_TYP7 (obj
))
106 result
= sizeof (long);
110 result
= sizeof (char);
114 result
= sizeof (short);
117 #ifdef HAVE_LONG_LONGS
119 result
= sizeof (long long);
124 result
= sizeof (float);
128 result
= sizeof (double);
132 result
= 2 * sizeof (double);
141 /* Silly function used not to modify the semantics of the silly
142 * prototype system in order to be backward compatible.
147 if (!SCM_SLOPPY_REALP (obj
))
151 double x
= SCM_REAL_VALUE (obj
);
153 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
158 scm_make_uve (long k
, SCM prot
)
159 #define FUNC_NAME "scm_make_uve"
164 if (SCM_EQ_P (prot
, SCM_BOOL_T
))
169 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_BITVECTOR_MAX_LENGTH
);
170 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
171 SCM_SET_BITVECTOR_BASE (v
, (char *) scm_must_malloc (i
, "vector"));
172 SCM_SET_BITVECTOR_LENGTH (v
, k
);
176 SCM_SET_BITVECTOR_BASE (v
, 0);
177 SCM_SET_BITVECTOR_LENGTH (v
, 0);
181 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
183 i
= sizeof (char) * k
;
184 type
= scm_tc7_byvect
;
186 else if (SCM_CHARP (prot
))
188 i
= sizeof (char) * k
;
189 return scm_allocate_string (i
);
191 else if (SCM_INUMP (prot
))
193 i
= sizeof (long) * k
;
194 if (SCM_INUM (prot
) > 0)
195 type
= scm_tc7_uvect
;
197 type
= scm_tc7_ivect
;
199 else if (SCM_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
203 s
= SCM_SYMBOL_CHARS (prot
)[0];
206 i
= sizeof (short) * k
;
207 type
= scm_tc7_svect
;
209 #ifdef HAVE_LONG_LONGS
212 i
= sizeof (long long) * k
;
213 type
= scm_tc7_llvect
;
218 return scm_c_make_vector (k
, SCM_UNDEFINED
);
221 else if (!SCM_INEXACTP (prot
))
222 /* Huge non-unif vectors are NOT supported. */
223 /* no special scm_vector */
224 return scm_c_make_vector (k
, SCM_UNDEFINED
);
225 else if (singp (prot
))
227 i
= sizeof (float) * k
;
228 type
= scm_tc7_fvect
;
230 else if (SCM_COMPLEXP (prot
))
232 i
= 2 * sizeof (double) * k
;
233 type
= scm_tc7_cvect
;
237 i
= sizeof (double) * k
;
238 type
= scm_tc7_dvect
;
241 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_UVECTOR_MAX_LENGTH
);
245 SCM_SET_UVECTOR_BASE (v
, (char *) scm_must_malloc (i
? i
: 1, "vector"));
246 SCM_SET_UVECTOR_LENGTH (v
, k
, type
);
253 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
255 "Return the number of elements in @var{uve}.")
256 #define FUNC_NAME s_scm_uniform_vector_length
258 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
262 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
265 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v
));
267 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
269 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
277 #ifdef HAVE_LONG_LONGS
280 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v
));
285 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
287 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
288 "not. The @var{prototype} argument is used with uniform arrays\n"
289 "and is described elsewhere.")
290 #define FUNC_NAME s_scm_array_p
294 nprot
= SCM_UNBNDP (prot
);
299 while (SCM_TYP7 (v
) == scm_tc7_smob
)
310 return SCM_BOOL(nprot
);
315 switch (SCM_TYP7 (v
))
318 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
320 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
322 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
324 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
326 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
329 protp
= SCM_SYMBOLP (prot
)
330 && (1 == SCM_SYMBOL_LENGTH (prot
))
331 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
332 #ifdef HAVE_LONG_LONGS
334 protp
= SCM_SYMBOLP (prot
)
335 && (1 == SCM_SYMBOL_LENGTH (prot
))
336 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
339 protp
= singp (prot
);
341 protp
= SCM_REALP(prot
);
343 protp
= SCM_COMPLEXP(prot
);
346 protp
= SCM_NULLP(prot
);
351 return SCM_BOOL(protp
);
357 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
359 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
360 "not an array, @code{0} is returned.")
361 #define FUNC_NAME s_scm_array_rank
365 switch (SCM_TYP7 (ra
))
378 #ifdef HAVE_LONG_LONGS
382 return SCM_MAKINUM (1L);
385 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
392 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
394 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
395 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
397 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
399 #define FUNC_NAME s_scm_array_dimensions
406 switch (SCM_TYP7 (ra
))
421 #ifdef HAVE_LONG_LONGS
424 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
426 if (!SCM_ARRAYP (ra
))
428 k
= SCM_ARRAY_NDIM (ra
);
429 s
= SCM_ARRAY_DIMS (ra
);
431 res
= scm_cons (s
[k
].lbnd
432 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
433 SCM_MAKINUM (s
[k
].ubnd
),
435 : SCM_MAKINUM (1 + s
[k
].ubnd
),
443 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
445 "Return the root vector of a shared array.")
446 #define FUNC_NAME s_scm_shared_array_root
448 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
449 return SCM_ARRAY_V (ra
);
454 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
456 "Return the root vector index of the first element in the array.")
457 #define FUNC_NAME s_scm_shared_array_offset
459 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
460 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
465 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
467 "For each dimension, return the distance between elements in the root vector.")
468 #define FUNC_NAME s_scm_shared_array_increments
473 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
474 k
= SCM_ARRAY_NDIM (ra
);
475 s
= SCM_ARRAY_DIMS (ra
);
477 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
483 static char s_bad_ind
[] = "Bad scm_array index";
487 scm_aind (SCM ra
, SCM args
, const char *what
)
488 #define FUNC_NAME what
492 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
493 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
494 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
495 if (SCM_INUMP (args
))
498 scm_error_num_args_subr (what
);
499 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
501 while (k
&& !SCM_NULLP (args
))
503 ind
= SCM_CAR (args
);
504 args
= SCM_CDR (args
);
505 if (!SCM_INUMP (ind
))
506 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
508 if (j
< s
->lbnd
|| j
> s
->ubnd
)
509 scm_out_of_range (what
, ind
);
510 pos
+= (j
- s
->lbnd
) * (s
->inc
);
514 if (k
!= 0 || !SCM_NULLP (args
))
515 scm_error_num_args_subr (what
);
523 scm_make_ra (int ndim
)
528 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_tc16_array
,
529 scm_must_malloc ((sizeof (scm_t_array
) +
530 ndim
* sizeof (scm_t_array_dim
)),
532 SCM_ARRAY_V (ra
) = scm_nullvect
;
537 static char s_bad_spec
[] = "Bad scm_array dimension";
538 /* Increments will still need to be set. */
542 scm_shap2ra (SCM args
, const char *what
)
546 int ndim
= scm_ilength (args
);
548 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
550 ra
= scm_make_ra (ndim
);
551 SCM_ARRAY_BASE (ra
) = 0;
552 s
= SCM_ARRAY_DIMS (ra
);
553 for (; !SCM_NULLP (args
); s
++, args
= SCM_CDR (args
))
555 spec
= SCM_CAR (args
);
556 if (SCM_INUMP (spec
))
558 if (SCM_INUM (spec
) < 0)
559 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
561 s
->ubnd
= SCM_INUM (spec
) - 1;
566 if (!SCM_CONSP (spec
) || !SCM_INUMP (SCM_CAR (spec
)))
567 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
568 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
571 || !SCM_INUMP (SCM_CAR (sp
))
572 || !SCM_NULLP (SCM_CDR (sp
)))
573 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
574 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
581 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
582 (SCM dims
, SCM prot
, SCM fill
),
583 "@deffnx primitive make-uniform-vector length prototype [fill]\n"
584 "Create and return a uniform array or vector of type\n"
585 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
586 "length @var{length}. If @var{fill} is supplied, it's used to\n"
587 "fill the array, otherwise @var{prototype} is used.")
588 #define FUNC_NAME s_scm_dimensions_to_uniform_array
591 unsigned long rlen
= 1;
595 if (SCM_INUMP (dims
))
597 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
598 if (!SCM_UNBNDP (fill
))
599 scm_array_fill_x (answer
, fill
);
600 else if (SCM_SYMBOLP (prot
))
601 scm_array_fill_x (answer
, SCM_MAKINUM (0));
603 scm_array_fill_x (answer
, prot
);
607 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
608 dims
, SCM_ARG1
, FUNC_NAME
);
609 ra
= scm_shap2ra (dims
, FUNC_NAME
);
610 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
611 s
= SCM_ARRAY_DIMS (ra
);
612 k
= SCM_ARRAY_NDIM (ra
);
617 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
618 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
621 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
623 if (!SCM_UNBNDP (fill
))
624 scm_array_fill_x (ra
, fill
);
625 else if (SCM_SYMBOLP (prot
))
626 scm_array_fill_x (ra
, SCM_MAKINUM (0));
628 scm_array_fill_x (ra
, prot
);
630 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
631 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
632 return SCM_ARRAY_V (ra
);
639 scm_ra_set_contp (SCM ra
)
641 size_t k
= SCM_ARRAY_NDIM (ra
);
644 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
647 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
649 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
652 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
653 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
656 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
660 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
661 (SCM oldra
, SCM mapfunc
, SCM dims
),
662 "@code{make-shared-array} can be used to create shared subarrays of other\n"
663 "arrays. The @var{mapper} is a function that translates coordinates in\n"
664 "the new array into coordinates in the old array. A @var{mapper} must be\n"
665 "linear, and its range must stay within the bounds of the old array, but\n"
666 "it can be otherwise arbitrary. A simple example:\n"
668 "(define fred (make-array #f 8 8))\n"
669 "(define freds-diagonal\n"
670 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
671 "(array-set! freds-diagonal 'foo 3)\n"
672 "(array-ref fred 3 3) @result{} foo\n"
673 "(define freds-center\n"
674 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
675 "(array-ref freds-center 0 0) @result{} foo\n"
677 #define FUNC_NAME s_scm_make_shared_array
683 long old_min
, new_min
, old_max
, new_max
;
686 SCM_VALIDATE_REST_ARGUMENT (dims
);
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
= SCM_INUM (scm_uniform_vector_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_0 (mapfunc
, scm_reverse (inds
));
725 if (SCM_ARRAYP (oldra
))
726 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
729 if (SCM_NINUMP (imap
))
732 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
733 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
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_0 (mapfunc
, scm_reverse (inds
));
747 if (SCM_ARRAYP (oldra
))
749 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
752 if (SCM_NINUMP (imap
))
754 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
755 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
756 imap
= SCM_CAR (imap
);
758 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
762 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
764 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
767 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
768 indptr
= SCM_CDR (indptr
);
770 if (old_min
> new_min
|| old_max
< new_max
)
771 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
772 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
774 SCM v
= SCM_ARRAY_V (ra
);
775 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
776 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
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 "Return an array sharing contents with @var{array}, but with\n"
791 "dimensions arranged in a different order. There must be one\n"
792 "@var{dim} argument for each dimension of @var{array}.\n"
793 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
794 "and the rank of the array to be returned. Each integer in that\n"
795 "range must appear at least once in the argument list.\n"
797 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
798 "dimensions in the array to be returned, their positions in the\n"
799 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
800 "may have the same value, in which case the returned array will\n"
801 "have smaller rank than @var{array}.\n"
804 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
805 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
806 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
807 " #2((a 4) (b 5) (c 6))\n"
809 #define FUNC_NAME s_scm_transpose_array
811 SCM res
, vargs
, *ve
= &vargs
;
812 scm_t_array_dim
*s
, *r
;
815 SCM_VALIDATE_REST_ARGUMENT (args
);
816 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
817 switch (SCM_TYP7 (ra
))
820 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
830 #ifdef HAVE_LONG_LONGS
833 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
834 SCM_WRONG_NUM_ARGS ();
835 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CAR (args
));
836 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
837 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
840 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
841 vargs
= scm_vector (args
);
842 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
843 SCM_WRONG_NUM_ARGS ();
844 ve
= SCM_VELTS (vargs
);
846 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
848 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
850 i
= SCM_INUM (ve
[k
]);
851 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
852 scm_out_of_range (FUNC_NAME
, ve
[k
]);
857 res
= scm_make_ra (ndim
);
858 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
859 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
862 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
863 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
865 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
867 i
= SCM_INUM (ve
[k
]);
868 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
869 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
870 if (r
->ubnd
< r
->lbnd
)
879 if (r
->ubnd
> s
->ubnd
)
881 if (r
->lbnd
< s
->lbnd
)
883 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
890 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
891 scm_ra_set_contp (res
);
897 /* args are RA . AXES */
898 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
900 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
901 "the rank of @var{array}. @var{enclose-array} returns an array\n"
902 "resembling an array of shared arrays. The dimensions of each shared\n"
903 "array are the same as the @var{dim}th dimensions of the original array,\n"
904 "the dimensions of the outer array are the same as those of the original\n"
905 "array that did not match a @var{dim}.\n\n"
906 "An enclosed array is not a general Scheme array. Its elements may not\n"
907 "be set using @code{array-set!}. Two references to the same element of\n"
908 "an enclosed array will be @code{equal?} but will not in general be\n"
909 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
910 "enclosed array is unspecified.\n\n"
913 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
914 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
915 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
916 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
918 #define FUNC_NAME s_scm_enclose_array
920 SCM axv
, res
, ra_inr
;
921 scm_t_array_dim vdim
, *s
= &vdim
;
922 int ndim
, j
, k
, ninr
, noutr
;
924 SCM_VALIDATE_REST_ARGUMENT (axes
);
925 if (SCM_NULLP (axes
))
926 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
927 ninr
= scm_ilength (axes
);
929 SCM_WRONG_NUM_ARGS ();
930 ra_inr
= scm_make_ra (ninr
);
931 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
935 badarg1
:SCM_WRONG_TYPE_ARG (1, ra
);
947 #ifdef HAVE_LONG_LONGS
951 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
953 SCM_ARRAY_V (ra_inr
) = ra
;
954 SCM_ARRAY_BASE (ra_inr
) = 0;
958 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
959 s
= SCM_ARRAY_DIMS (ra
);
960 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
961 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
962 ndim
= SCM_ARRAY_NDIM (ra
);
967 SCM_WRONG_NUM_ARGS ();
968 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
969 res
= scm_make_ra (noutr
);
970 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
971 SCM_ARRAY_V (res
) = ra_inr
;
972 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
974 if (!SCM_INUMP (SCM_CAR (axes
)))
975 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
976 j
= SCM_INUM (SCM_CAR (axes
));
977 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
978 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
979 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
980 SCM_STRING_CHARS (axv
)[j
] = 1;
982 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
984 while (SCM_STRING_CHARS (axv
)[j
])
986 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
987 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
988 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
990 scm_ra_set_contp (ra_inr
);
991 scm_ra_set_contp (res
);
998 SCM_DEFINE (scm_array_in_bounds_p
, "array-in-bounds?", 1, 0, 1,
1000 "Return @code{#t} if its arguments would be acceptable to\n"
1001 "@code{array-ref}.")
1002 #define FUNC_NAME s_scm_array_in_bounds_p
1010 SCM_VALIDATE_REST_ARGUMENT (args
);
1011 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1012 if (SCM_NIMP (args
))
1015 ind
= SCM_CAR (args
);
1016 args
= SCM_CDR (args
);
1017 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
1018 pos
= SCM_INUM (ind
);
1024 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1025 wna
: SCM_WRONG_NUM_ARGS ();
1027 k
= SCM_ARRAY_NDIM (v
);
1028 s
= SCM_ARRAY_DIMS (v
);
1029 pos
= SCM_ARRAY_BASE (v
);
1032 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1039 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1041 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1044 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1045 if (!(--k
&& SCM_NIMP (args
)))
1047 ind
= SCM_CAR (args
);
1048 args
= SCM_CDR (args
);
1050 if (!SCM_INUMP (ind
))
1051 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
1053 SCM_ASRTGO (0 == k
, wna
);
1054 v
= SCM_ARRAY_V (v
);
1057 case scm_tc7_string
:
1058 case scm_tc7_byvect
:
1065 #ifdef HAVE_LONG_LONGS
1066 case scm_tc7_llvect
:
1068 case scm_tc7_vector
:
1071 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1072 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1073 return SCM_BOOL(pos
>= 0 && pos
< length
);
1080 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1083 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1085 "@deffnx primitive array-ref v . args\n"
1086 "Return the element at the @code{(index1, index2)} element in\n"
1088 #define FUNC_NAME s_scm_uniform_vector_ref
1094 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1097 else if (SCM_ARRAYP (v
))
1099 pos
= scm_aind (v
, args
, FUNC_NAME
);
1100 v
= SCM_ARRAY_V (v
);
1104 unsigned long int length
;
1105 if (SCM_NIMP (args
))
1107 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1108 pos
= SCM_INUM (SCM_CAR (args
));
1109 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1113 SCM_VALIDATE_INUM (2,args
);
1114 pos
= SCM_INUM (args
);
1116 length
= SCM_INUM (scm_uniform_vector_length (v
));
1117 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1122 if (SCM_NULLP (args
))
1125 SCM_WRONG_TYPE_ARG (1, v
);
1129 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1131 SCM_WRONG_NUM_ARGS ();
1134 int k
= SCM_ARRAY_NDIM (v
);
1135 SCM res
= scm_make_ra (k
);
1136 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1137 SCM_ARRAY_BASE (res
) = pos
;
1140 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1141 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1142 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1147 if (SCM_BITVEC_REF (v
, pos
))
1151 case scm_tc7_string
:
1152 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1153 case scm_tc7_byvect
:
1154 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1156 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1158 return scm_long2num (((signed long *) SCM_VELTS (v
))[pos
]);
1161 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1162 #ifdef HAVE_LONG_LONGS
1163 case scm_tc7_llvect
:
1164 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1168 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1170 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1172 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1173 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1174 case scm_tc7_vector
:
1176 return SCM_VELTS (v
)[pos
];
1181 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1182 tries to recycle conses. (Make *sure* you want them recycled.) */
1185 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1186 #define FUNC_NAME "scm_cvref"
1191 SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1193 if (SCM_BITVEC_REF(v
,pos
))
1197 case scm_tc7_string
:
1198 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1199 case scm_tc7_byvect
:
1200 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1202 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1204 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1206 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1207 #ifdef HAVE_LONG_LONGS
1208 case scm_tc7_llvect
:
1209 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1212 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1214 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1217 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1219 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1221 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1224 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1226 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1228 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1229 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1232 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1233 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1234 case scm_tc7_vector
:
1236 return SCM_VELTS (v
)[pos
];
1238 { /* enclosed scm_array */
1239 int k
= SCM_ARRAY_NDIM (v
);
1240 SCM res
= scm_make_ra (k
);
1241 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1242 SCM_ARRAY_BASE (res
) = pos
;
1245 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1246 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1247 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1256 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1259 /* Note that args may be a list or an immediate object, depending which
1260 PROC is used (and it's called from C too). */
1261 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1262 (SCM v
, SCM obj
, SCM args
),
1263 "@deffnx primitive uniform-array-set1! v obj args\n"
1264 "Sets the element at the @code{(index1, index2)} element in @var{array} to\n"
1265 "@var{new-value}. The value returned by array-set! is unspecified.")
1266 #define FUNC_NAME s_scm_array_set_x
1270 SCM_VALIDATE_REST_ARGUMENT (args
);
1271 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1274 pos
= scm_aind (v
, args
, FUNC_NAME
);
1275 v
= SCM_ARRAY_V (v
);
1279 unsigned long int length
;
1280 if (SCM_NIMP (args
))
1282 SCM_ASSERT (SCM_CONSP(args
) && SCM_INUMP (SCM_CAR (args
)), args
,
1283 SCM_ARG3
, FUNC_NAME
);
1284 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1285 pos
= SCM_INUM (SCM_CAR (args
));
1289 SCM_VALIDATE_INUM_COPY (3,args
,pos
);
1291 length
= SCM_INUM (scm_uniform_vector_length (v
));
1292 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1294 switch (SCM_TYP7 (v
))
1297 SCM_WRONG_TYPE_ARG (1, v
);
1300 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1302 SCM_WRONG_NUM_ARGS ();
1303 case scm_tc7_smob
: /* enclosed */
1306 if (SCM_FALSEP (obj
))
1307 SCM_BITVEC_CLR(v
,pos
);
1308 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1309 SCM_BITVEC_SET(v
,pos
);
1311 badobj
:SCM_WRONG_TYPE_ARG (2, obj
);
1313 case scm_tc7_string
:
1314 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1315 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1317 case scm_tc7_byvect
:
1318 if (SCM_CHARP (obj
))
1319 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1320 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1321 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1324 ((unsigned long *) SCM_UVECTOR_BASE (v
))[pos
]
1325 = scm_num2ulong (obj
, SCM_ARG2
, FUNC_NAME
);
1328 ((long *) SCM_UVECTOR_BASE (v
))[pos
]
1329 = scm_num2long (obj
, SCM_ARG2
, FUNC_NAME
);
1332 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1333 ((short *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1335 #ifdef HAVE_LONG_LONGS
1336 case scm_tc7_llvect
:
1337 ((long long *) SCM_UVECTOR_BASE (v
))[pos
]
1338 = scm_num2long_long (obj
, SCM_ARG2
, FUNC_NAME
);
1342 ((float *) SCM_UVECTOR_BASE (v
))[pos
]
1343 = (float) scm_num2dbl (obj
, FUNC_NAME
);
1346 ((double *) SCM_UVECTOR_BASE (v
))[pos
]
1347 = scm_num2dbl (obj
, FUNC_NAME
);
1350 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1351 if (SCM_REALP (obj
)) {
1352 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1353 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = 0.0;
1355 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1356 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1359 case scm_tc7_vector
:
1361 SCM_VELTS (v
)[pos
] = obj
;
1364 return SCM_UNSPECIFIED
;
1368 /* attempts to unroll an array into a one-dimensional array.
1369 returns the unrolled array or #f if it can't be done. */
1370 /* if strict is not SCM_UNDEFINED, return #f if returned array
1371 wouldn't have contiguous elements. */
1372 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1373 (SCM ra
, SCM strict
),
1374 "@deffnx primitive array-contents array strict\n"
1375 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1376 "without changing their order (last subscript changing fastest), then\n"
1377 "@code{array-contents} returns that shared array, otherwise it returns\n"
1378 "@code{#f}. All arrays made by @var{make-array} and\n"
1379 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1380 "@var{make-shared-array} may not be.\n\n"
1381 "If the optional argument @var{strict} is provided, a shared array will\n"
1382 "be returned only if its elements are stored internally contiguous in\n"
1384 #define FUNC_NAME s_scm_array_contents
1389 switch SCM_TYP7 (ra
)
1393 case scm_tc7_vector
:
1395 case scm_tc7_string
:
1397 case scm_tc7_byvect
:
1404 #ifdef HAVE_LONG_LONGS
1405 case scm_tc7_llvect
:
1410 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1411 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1413 for (k
= 0; k
< ndim
; k
++)
1414 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1415 if (!SCM_UNBNDP (strict
))
1417 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1419 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1421 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1422 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1429 SCM v
= SCM_ARRAY_V (ra
);
1430 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1431 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1435 sra
= scm_make_ra (1);
1436 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1437 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1438 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1439 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1440 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1449 scm_ra2contig (SCM ra
, int copy
)
1454 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1455 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1456 k
= SCM_ARRAY_NDIM (ra
);
1457 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1459 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1461 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1462 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1463 0 == len
% SCM_LONG_BIT
))
1466 ret
= scm_make_ra (k
);
1467 SCM_ARRAY_BASE (ret
) = 0;
1470 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1471 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1472 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1473 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1475 SCM_ARRAY_V (ret
) = scm_make_uve ((inc
- 1), scm_array_prototype (ra
));
1477 scm_array_copy_x (ra
, ret
);
1483 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1484 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1485 "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1486 "Attempts to read all elements of @var{ura}, in lexicographic order, as\n"
1487 "binary objects from @var{port-or-fdes}.\n"
1488 "If an end of file is encountered during\n"
1489 "uniform-array-read! the objects up to that point only are put into @var{ura}\n"
1490 "(starting at the beginning) and the remainder of the array is\n"
1492 "The optional arguments @var{start} and @var{end} allow\n"
1493 "a specified region of a vector (or linearized array) to be read,\n"
1494 "leaving the remainder of the vector unchanged.\n\n"
1495 "@code{uniform-array-read!} returns the number of objects read.\n"
1496 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1497 "returned by @code{(current-input-port)}.")
1498 #define FUNC_NAME s_scm_uniform_array_read_x
1500 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1507 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1508 if (SCM_UNBNDP (port_or_fd
))
1509 port_or_fd
= scm_cur_inp
;
1511 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1512 || (SCM_OPINPORTP (port_or_fd
)),
1513 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1514 vlen
= SCM_INUM (scm_uniform_vector_length (v
));
1520 badarg1
:SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1522 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1523 cra
= scm_ra2contig (ra
, 0);
1524 cstart
+= SCM_ARRAY_BASE (cra
);
1525 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1526 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1527 v
= SCM_ARRAY_V (cra
);
1529 case scm_tc7_string
:
1530 base
= SCM_STRING_CHARS (v
);
1534 base
= (char *) SCM_BITVECTOR_BASE (v
);
1535 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1536 cstart
/= SCM_LONG_BIT
;
1539 case scm_tc7_byvect
:
1540 base
= (char *) SCM_UVECTOR_BASE (v
);
1545 base
= (char *) SCM_UVECTOR_BASE (v
);
1549 base
= (char *) SCM_UVECTOR_BASE (v
);
1550 sz
= sizeof (short);
1552 #ifdef HAVE_LONG_LONGS
1553 case scm_tc7_llvect
:
1554 base
= (char *) SCM_UVECTOR_BASE (v
);
1555 sz
= sizeof (long long);
1559 base
= (char *) SCM_UVECTOR_BASE (v
);
1560 sz
= sizeof (float);
1563 base
= (char *) SCM_UVECTOR_BASE (v
);
1564 sz
= sizeof (double);
1567 base
= (char *) SCM_UVECTOR_BASE (v
);
1568 sz
= 2 * sizeof (double);
1573 if (!SCM_UNBNDP (start
))
1576 SCM_NUM2LONG (3, start
);
1578 if (offset
< 0 || offset
>= cend
)
1579 scm_out_of_range (FUNC_NAME
, start
);
1581 if (!SCM_UNBNDP (end
))
1584 SCM_NUM2LONG (4, end
);
1586 if (tend
<= offset
|| tend
> cend
)
1587 scm_out_of_range (FUNC_NAME
, end
);
1592 if (SCM_NIMP (port_or_fd
))
1594 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1595 int remaining
= (cend
- offset
) * sz
;
1596 char *dest
= base
+ (cstart
+ offset
) * sz
;
1598 if (pt
->rw_active
== SCM_PORT_WRITE
)
1599 scm_flush (port_or_fd
);
1601 ans
= cend
- offset
;
1602 while (remaining
> 0)
1604 if (pt
->read_pos
< pt
->read_end
)
1606 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1609 memcpy (dest
, pt
->read_pos
, to_copy
);
1610 pt
->read_pos
+= to_copy
;
1611 remaining
-= to_copy
;
1616 if (scm_fill_input (port_or_fd
) == EOF
)
1618 if (remaining
% sz
!= 0)
1620 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1622 ans
-= remaining
/ sz
;
1629 pt
->rw_active
= SCM_PORT_READ
;
1631 else /* file descriptor. */
1633 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1634 base
+ (cstart
+ offset
) * sz
,
1635 (sz
* (cend
- offset
))));
1639 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1640 ans
*= SCM_LONG_BIT
;
1642 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1643 scm_array_copy_x (cra
, ra
);
1645 return SCM_MAKINUM (ans
);
1649 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1650 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1651 "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1652 "Writes all elements of @var{ura} as binary objects to\n"
1653 "@var{port-or-fdes}.\n\n"
1654 "The optional arguments @var{start}\n"
1655 "and @var{end} allow\n"
1656 "a specified region of a vector (or linearized array) to be written.\n\n"
1657 "The number of objects actually written is returned. \n"
1658 "@var{port-or-fdes} may be\n"
1659 "omitted, in which case it defaults to the value returned by\n"
1660 "@code{(current-output-port)}.")
1661 #define FUNC_NAME s_scm_uniform_array_write
1669 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1671 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1672 if (SCM_UNBNDP (port_or_fd
))
1673 port_or_fd
= scm_cur_outp
;
1675 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1676 || (SCM_OPOUTPORTP (port_or_fd
)),
1677 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1678 vlen
= SCM_INUM (scm_uniform_vector_length (v
));
1684 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1686 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1687 v
= scm_ra2contig (v
, 1);
1688 cstart
= SCM_ARRAY_BASE (v
);
1689 vlen
= SCM_ARRAY_DIMS (v
)->inc
1690 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1691 v
= SCM_ARRAY_V (v
);
1693 case scm_tc7_string
:
1694 base
= SCM_STRING_CHARS (v
);
1698 base
= (char *) SCM_BITVECTOR_BASE (v
);
1699 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1700 cstart
/= SCM_LONG_BIT
;
1703 case scm_tc7_byvect
:
1704 base
= (char *) SCM_UVECTOR_BASE (v
);
1709 base
= (char *) SCM_UVECTOR_BASE (v
);
1713 base
= (char *) SCM_UVECTOR_BASE (v
);
1714 sz
= sizeof (short);
1716 #ifdef HAVE_LONG_LONGS
1717 case scm_tc7_llvect
:
1718 base
= (char *) SCM_UVECTOR_BASE (v
);
1719 sz
= sizeof (long long);
1723 base
= (char *) SCM_UVECTOR_BASE (v
);
1724 sz
= sizeof (float);
1727 base
= (char *) SCM_UVECTOR_BASE (v
);
1728 sz
= sizeof (double);
1731 base
= (char *) SCM_UVECTOR_BASE (v
);
1732 sz
= 2 * sizeof (double);
1737 if (!SCM_UNBNDP (start
))
1740 SCM_NUM2LONG (3, start
);
1742 if (offset
< 0 || offset
>= cend
)
1743 scm_out_of_range (FUNC_NAME
, start
);
1745 if (!SCM_UNBNDP (end
))
1748 SCM_NUM2LONG (4, end
);
1750 if (tend
<= offset
|| tend
> cend
)
1751 scm_out_of_range (FUNC_NAME
, end
);
1756 if (SCM_NIMP (port_or_fd
))
1758 char *source
= base
+ (cstart
+ offset
) * sz
;
1760 ans
= cend
- offset
;
1761 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1763 else /* file descriptor. */
1765 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1766 base
+ (cstart
+ offset
) * sz
,
1767 (sz
* (cend
- offset
))));
1771 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1772 ans
*= SCM_LONG_BIT
;
1774 return SCM_MAKINUM (ans
);
1779 static char cnt_tab
[16] =
1780 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1782 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1783 (SCM b
, SCM bitvector
),
1784 "Return the number of occurrences of the boolean @var{b} in\n"
1786 #define FUNC_NAME s_scm_bit_count
1788 SCM_VALIDATE_BOOL (1, b
);
1789 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1790 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1793 unsigned long int count
= 0;
1794 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1795 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1796 if (SCM_FALSEP (b
)) {
1799 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1802 count
+= cnt_tab
[w
& 0x0f];
1806 return SCM_MAKINUM (count
);
1809 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1810 if (SCM_FALSEP (b
)) {
1820 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1821 (SCM item
, SCM v
, SCM k
),
1822 "Return the minimum index of an occurrence of @var{bool} in\n"
1823 "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
1824 "within the specified range @code{#f} is returned.")
1825 #define FUNC_NAME s_scm_bit_position
1827 long i
, lenw
, xbits
, pos
;
1828 register unsigned long w
;
1830 SCM_VALIDATE_BOOL (1, item
);
1831 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1832 SCM_VALIDATE_INUM_COPY (3,k
,pos
);
1833 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1835 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1838 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1839 i
= pos
/ SCM_LONG_BIT
;
1840 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1841 if (SCM_FALSEP (item
))
1843 xbits
= (pos
% SCM_LONG_BIT
);
1845 w
= ((w
>> xbits
) << xbits
);
1846 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1849 if (w
&& (i
== lenw
))
1850 w
= ((w
<< xbits
) >> xbits
);
1856 return SCM_MAKINUM (pos
);
1861 return SCM_MAKINUM (pos
+ 1);
1864 return SCM_MAKINUM (pos
+ 2);
1866 return SCM_MAKINUM (pos
+ 3);
1873 pos
+= SCM_LONG_BIT
;
1874 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1875 if (SCM_FALSEP (item
))
1883 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1884 (SCM v
, SCM kv
, SCM obj
),
1885 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1886 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1887 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1888 "AND'ed into @var{bv}.\n\n"
1889 "If uve is a unsigned integer vector all the elements of uve\n"
1890 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1891 "of @var{bv} corresponding to the indexes in uve are set to\n"
1892 "@var{bool}. The return value is unspecified.")
1893 #define FUNC_NAME s_scm_bit_set_star_x
1895 register long i
, k
, vlen
;
1896 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1897 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1898 switch SCM_TYP7 (kv
)
1901 badarg2
:SCM_WRONG_TYPE_ARG (2, kv
);
1903 vlen
= SCM_BITVECTOR_LENGTH (v
);
1904 if (SCM_FALSEP (obj
))
1905 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1907 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1909 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1910 SCM_BITVEC_CLR(v
,k
);
1912 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1913 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1915 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1917 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1918 SCM_BITVEC_SET(v
,k
);
1921 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1924 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1925 if (SCM_FALSEP (obj
))
1926 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1927 SCM_BITVECTOR_BASE (v
) [k
] &= ~SCM_BITVECTOR_BASE (kv
) [k
];
1928 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1929 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1930 SCM_BITVECTOR_BASE (v
) [k
] |= SCM_BITVECTOR_BASE (kv
) [k
];
1935 return SCM_UNSPECIFIED
;
1940 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1941 (SCM v
, SCM kv
, SCM obj
),
1944 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1946 "@var{bv} is not modified.")
1947 #define FUNC_NAME s_scm_bit_count_star
1949 register long i
, vlen
, count
= 0;
1950 register unsigned long k
;
1953 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1954 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1955 switch SCM_TYP7 (kv
)
1959 SCM_WRONG_TYPE_ARG (2, kv
);
1961 vlen
= SCM_BITVECTOR_LENGTH (v
);
1962 if (SCM_FALSEP (obj
))
1963 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1965 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1967 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1968 if (!SCM_BITVEC_REF(v
,k
))
1971 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1972 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1974 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1976 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1977 if (SCM_BITVEC_REF (v
,k
))
1981 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1984 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1985 if (0 == SCM_BITVECTOR_LENGTH (v
))
1987 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1988 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1989 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1990 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1991 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1995 count
+= cnt_tab
[k
& 0x0f];
1997 return SCM_MAKINUM (count
);
1999 /* urg. repetitive (see above.) */
2000 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
2003 return SCM_MAKINUM (count
);
2008 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2010 "Modifies @var{bv} by replacing each element with its negation.")
2011 #define FUNC_NAME s_scm_bit_invert_x
2015 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
2017 k
= SCM_BITVECTOR_LENGTH (v
);
2018 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
2019 SCM_BITVECTOR_BASE (v
) [k
] = ~SCM_BITVECTOR_BASE (v
) [k
];
2021 return SCM_UNSPECIFIED
;
2027 scm_istr2bve (char *str
, long len
)
2029 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
2030 long *data
= (long *) SCM_VELTS (v
);
2031 register unsigned long mask
;
2034 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2037 j
= len
- k
* SCM_LONG_BIT
;
2038 if (j
> SCM_LONG_BIT
)
2040 for (mask
= 1L; j
--; mask
<<= 1)
2058 ra2l (SCM ra
,unsigned long base
,unsigned long k
)
2060 register SCM res
= SCM_EOL
;
2061 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2063 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2065 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2066 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2071 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2079 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2086 SCM_DEFINE (scm_t_arrayo_list
, "array->list", 1, 0, 0,
2088 "Return a list consisting of all the elements, in order, of\n"
2090 #define FUNC_NAME s_scm_t_arrayo_list
2094 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2098 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
2100 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2101 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2102 case scm_tc7_vector
:
2104 return scm_vector_to_list (v
);
2105 case scm_tc7_string
:
2106 return scm_string_to_list (v
);
2109 long *data
= (long *) SCM_VELTS (v
);
2110 register unsigned long mask
;
2111 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2112 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2113 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2114 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2115 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2118 case scm_tc7_byvect
:
2120 signed char *data
= (signed char *) SCM_VELTS (v
);
2121 unsigned long k
= SCM_UVECTOR_LENGTH (v
);
2123 res
= scm_cons (SCM_MAKINUM (data
[--k
]), res
);
2128 long *data
= (long *)SCM_VELTS(v
);
2129 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2130 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2135 long *data
= (long *)SCM_VELTS(v
);
2136 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2137 res
= scm_cons(scm_long2num(data
[k
]), res
);
2142 short *data
= (short *)SCM_VELTS(v
);
2143 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2144 res
= scm_cons(scm_short2num (data
[k
]), res
);
2147 #ifdef HAVE_LONG_LONGS
2148 case scm_tc7_llvect
:
2150 long long *data
= (long long *)SCM_VELTS(v
);
2151 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2152 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2158 float *data
= (float *) SCM_VELTS (v
);
2159 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2160 res
= scm_cons (scm_make_real (data
[k
]), res
);
2165 double *data
= (double *) SCM_VELTS (v
);
2166 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2167 res
= scm_cons (scm_make_real (data
[k
]), res
);
2172 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2173 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2174 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2182 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2184 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2185 (SCM ndim
, SCM prot
, SCM lst
),
2186 "@deffnx procedure list->uniform-vector prot lst\n"
2187 "Return a uniform array of the type indicated by prototype\n"
2188 "@var{prot} with elements the same as those of @var{lst}.\n"
2189 "Elements must be of the appropriate type, no coercions are\n"
2191 #define FUNC_NAME s_scm_list_to_uniform_array
2198 SCM_VALIDATE_INUM_COPY (1,ndim
,k
);
2201 n
= scm_ilength (row
);
2202 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2203 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2205 row
= SCM_CAR (row
);
2207 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2209 if (SCM_NULLP (shp
))
2211 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2212 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2215 if (!SCM_ARRAYP (ra
))
2217 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2218 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2219 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2222 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2225 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst
));
2230 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2232 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2233 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2236 return (SCM_NULLP (lst
));
2237 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2241 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2243 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2245 lst
= SCM_CDR (lst
);
2247 if (SCM_NNULLP (lst
))
2254 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2256 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2258 lst
= SCM_CDR (lst
);
2260 if (SCM_NNULLP (lst
))
2268 rapr1 (SCM ra
,unsigned long j
,unsigned long k
,SCM port
,scm_print_state
*pstate
)
2271 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2273 : SCM_INUM (scm_uniform_vector_length (ra
)));
2276 switch SCM_TYP7 (ra
)
2281 SCM_ARRAY_BASE (ra
) = j
;
2283 scm_iprin1 (ra
, port
, pstate
);
2284 for (j
+= inc
; n
-- > 0; j
+= inc
)
2286 scm_putc (' ', port
);
2287 SCM_ARRAY_BASE (ra
) = j
;
2288 scm_iprin1 (ra
, port
, pstate
);
2292 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2295 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2296 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2298 scm_putc ('(', port
);
2299 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2300 scm_puts (") ", port
);
2303 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2304 { /* could be zero size. */
2305 scm_putc ('(', port
);
2306 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2307 scm_putc (')', port
);
2311 if (SCM_ARRAY_NDIM (ra
) > 0)
2312 { /* Could be zero-dimensional */
2313 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2314 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2318 ra
= SCM_ARRAY_V (ra
);
2321 /* scm_tc7_bvect and scm_tc7_llvect only? */
2323 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2324 for (j
+= inc
; n
-- > 0; j
+= inc
)
2326 scm_putc (' ', port
);
2327 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2330 case scm_tc7_string
:
2332 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2333 if (SCM_WRITINGP (pstate
))
2334 for (j
+= inc
; n
-- > 0; j
+= inc
)
2336 scm_putc (' ', port
);
2337 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2340 for (j
+= inc
; n
-- > 0; j
+= inc
)
2341 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2343 case scm_tc7_byvect
:
2345 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2346 for (j
+= inc
; n
-- > 0; j
+= inc
)
2348 scm_putc (' ', port
);
2349 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2359 /* intprint can't handle >= 2^31. */
2360 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2361 scm_puts (str
, port
);
2363 for (j
+= inc
; n
-- > 0; j
+= inc
)
2365 scm_putc (' ', port
);
2366 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2367 scm_puts (str
, port
);
2372 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2373 for (j
+= inc
; n
-- > 0; j
+= inc
)
2375 scm_putc (' ', port
);
2376 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2382 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2383 for (j
+= inc
; n
-- > 0; j
+= inc
)
2385 scm_putc (' ', port
);
2386 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2393 SCM z
= scm_make_real (1.0);
2394 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2395 scm_print_real (z
, port
, pstate
);
2396 for (j
+= inc
; n
-- > 0; j
+= inc
)
2398 scm_putc (' ', port
);
2399 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2400 scm_print_real (z
, port
, pstate
);
2407 SCM z
= scm_make_real (1.0 / 3.0);
2408 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2409 scm_print_real (z
, port
, pstate
);
2410 for (j
+= inc
; n
-- > 0; j
+= inc
)
2412 scm_putc (' ', port
);
2413 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2414 scm_print_real (z
, port
, pstate
);
2421 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2422 SCM_REAL_VALUE (z
) =
2423 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2424 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2425 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2427 for (j
+= inc
; n
-- > 0; j
+= inc
)
2429 scm_putc (' ', port
);
2431 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2432 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2433 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2444 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2447 unsigned long base
= 0;
2448 scm_putc ('#', port
);
2454 long ndim
= SCM_ARRAY_NDIM (v
);
2455 base
= SCM_ARRAY_BASE (v
);
2456 v
= SCM_ARRAY_V (v
);
2460 scm_puts ("<enclosed-array ", port
);
2461 rapr1 (exp
, base
, 0, port
, pstate
);
2462 scm_putc ('>', port
);
2467 scm_intprint (ndim
, 10, port
);
2472 if (SCM_EQ_P (exp
, v
))
2473 { /* a uve, not an scm_array */
2474 register long i
, j
, w
;
2475 scm_putc ('*', port
);
2476 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2478 scm_t_bits w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2479 for (j
= SCM_LONG_BIT
; j
; j
--)
2481 scm_putc (w
& 1 ? '1' : '0', port
);
2485 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2488 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2491 scm_putc (w
& 1 ? '1' : '0', port
);
2498 scm_putc ('b', port
);
2500 case scm_tc7_string
:
2501 scm_putc ('a', port
);
2503 case scm_tc7_byvect
:
2504 scm_putc ('y', port
);
2507 scm_putc ('u', port
);
2510 scm_putc ('e', port
);
2513 scm_putc ('h', port
);
2515 #ifdef HAVE_LONG_LONGS
2516 case scm_tc7_llvect
:
2517 scm_putc ('l', port
);
2521 scm_putc ('s', port
);
2524 scm_putc ('i', port
);
2527 scm_putc ('c', port
);
2530 scm_putc ('(', port
);
2531 rapr1 (exp
, base
, 0, port
, pstate
);
2532 scm_putc (')', port
);
2536 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2538 "Return an object that would produce an array of the same type\n"
2539 "as @var{array}, if used as the @var{prototype} for\n"
2540 "@code{make-uniform-array}.")
2541 #define FUNC_NAME s_scm_array_prototype
2544 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2546 switch SCM_TYP7 (ra
)
2549 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
2551 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2553 return SCM_UNSPECIFIED
;
2554 ra
= SCM_ARRAY_V (ra
);
2556 case scm_tc7_vector
:
2561 case scm_tc7_string
:
2562 return SCM_MAKE_CHAR ('a');
2563 case scm_tc7_byvect
:
2564 return SCM_MAKE_CHAR ('\0');
2566 return SCM_MAKINUM (1L);
2568 return SCM_MAKINUM (-1L);
2570 return scm_str2symbol ("s");
2571 #ifdef HAVE_LONG_LONGS
2572 case scm_tc7_llvect
:
2573 return scm_str2symbol ("l");
2576 return scm_make_real (1.0);
2578 return scm_make_real (1.0 / 3.0);
2580 return scm_make_complex (0.0, 1.0);
2587 array_mark (SCM ptr
)
2589 return SCM_ARRAY_V (ptr
);
2594 array_free (SCM ptr
)
2596 scm_must_free (SCM_ARRAY_MEM (ptr
));
2597 return sizeof (scm_t_array
) +
2598 SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
);
2604 scm_tc16_array
= scm_make_smob_type ("array", 0);
2605 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2606 scm_set_smob_free (scm_tc16_array
, array_free
);
2607 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2608 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2609 scm_add_feature ("array");
2610 #ifndef SCM_MAGIC_SNARFER
2611 #include "libguile/unif.x"