1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 This file has code for arrays in lots of variants (double, integer,
45 unsigned etc. ). It suffers from hugely repetitive code because
46 there is similar (but different) code for every variant included. (urg.)
56 #include "libguile/_scm.h"
57 #include "libguile/chars.h"
58 #include "libguile/eval.h"
59 #include "libguile/fports.h"
60 #include "libguile/smob.h"
61 #include "libguile/strop.h"
62 #include "libguile/feature.h"
63 #include "libguile/root.h"
64 #include "libguile/strings.h"
65 #include "libguile/vectors.h"
67 #include "libguile/validate.h"
68 #include "libguile/unif.h"
69 #include "libguile/ramap.h"
80 /* The set of uniform scm_vector types is:
82 * unsigned char string
89 * complex double cvect
94 scm_t_bits scm_tc16_array
;
96 /* return the size of an element in a uniform array or 0 if type not
99 scm_uniform_element_size (SCM obj
)
103 switch (SCM_TYP7 (obj
))
108 result
= sizeof (long);
112 result
= sizeof (char);
116 result
= sizeof (short);
119 #ifdef HAVE_LONG_LONGS
121 result
= sizeof (long long);
126 result
= sizeof (float);
130 result
= sizeof (double);
134 result
= 2 * sizeof (double);
143 /* Silly function used not to modify the semantics of the silly
144 * prototype system in order to be backward compatible.
149 if (!SCM_SLOPPY_REALP (obj
))
153 double x
= SCM_REAL_VALUE (obj
);
155 return (- SCM_FLTMAX
< x
) && (x
< SCM_FLTMAX
) && (fx
== x
);
160 scm_make_uve (long k
, SCM prot
)
161 #define FUNC_NAME "scm_make_uve"
166 if (SCM_EQ_P (prot
, SCM_BOOL_T
))
171 scm_long2num (k
), k
<= SCM_BITVECTOR_MAX_LENGTH
);
172 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
173 v
= scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (k
),
174 (scm_t_bits
) scm_gc_malloc (i
, "vector"));
177 v
= scm_alloc_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
180 else if (SCM_CHARP (prot
) && (SCM_CHAR (prot
) == '\0'))
182 i
= sizeof (char) * k
;
183 type
= scm_tc7_byvect
;
185 else if (SCM_CHARP (prot
))
187 i
= sizeof (char) * k
;
188 return scm_allocate_string (i
);
190 else if (SCM_INUMP (prot
))
192 i
= sizeof (long) * k
;
193 if (SCM_INUM (prot
) > 0)
194 type
= scm_tc7_uvect
;
196 type
= scm_tc7_ivect
;
198 else if (SCM_SYMBOLP (prot
) && (1 == SCM_SYMBOL_LENGTH (prot
)))
202 s
= SCM_SYMBOL_CHARS (prot
)[0];
205 i
= sizeof (short) * k
;
206 type
= scm_tc7_svect
;
208 #ifdef HAVE_LONG_LONGS
211 i
= sizeof (long long) * k
;
212 type
= scm_tc7_llvect
;
217 return scm_c_make_vector (k
, SCM_UNDEFINED
);
220 else if (!SCM_INEXACTP (prot
))
221 /* Huge non-unif vectors are NOT supported. */
222 /* no special scm_vector */
223 return scm_c_make_vector (k
, SCM_UNDEFINED
);
224 else if (singp (prot
))
226 i
= sizeof (float) * k
;
227 type
= scm_tc7_fvect
;
229 else if (SCM_COMPLEXP (prot
))
231 i
= 2 * sizeof (double) * k
;
232 type
= scm_tc7_cvect
;
236 i
= sizeof (double) * k
;
237 type
= scm_tc7_dvect
;
240 SCM_ASSERT_RANGE (1, scm_long2num (k
), k
<= SCM_UVECTOR_MAX_LENGTH
);
242 return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (k
, type
),
243 (scm_t_bits
) scm_gc_malloc (i
, "vector"));
248 SCM_DEFINE (scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
250 "Return the number of elements in @var{uve}.")
251 #define FUNC_NAME s_scm_uniform_vector_length
253 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
257 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
260 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v
));
262 return SCM_MAKINUM (SCM_STRING_LENGTH (v
));
264 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v
));
272 #ifdef HAVE_LONG_LONGS
275 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v
));
280 SCM_DEFINE (scm_array_p
, "array?", 1, 1, 0,
282 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
283 "not. The @var{prototype} argument is used with uniform arrays\n"
284 "and is described elsewhere.")
285 #define FUNC_NAME s_scm_array_p
289 nprot
= SCM_UNBNDP (prot
);
294 while (SCM_TYP7 (v
) == scm_tc7_smob
)
305 return SCM_BOOL(nprot
);
310 switch (SCM_TYP7 (v
))
313 protp
= (SCM_EQ_P (prot
, SCM_BOOL_T
));
315 protp
= SCM_CHARP(prot
) && (SCM_CHAR (prot
) != '\0');
317 protp
= SCM_EQ_P (prot
, SCM_MAKE_CHAR ('\0'));
319 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)>0;
321 protp
= SCM_INUMP(prot
) && SCM_INUM(prot
)<=0;
324 protp
= SCM_SYMBOLP (prot
)
325 && (1 == SCM_SYMBOL_LENGTH (prot
))
326 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
327 #ifdef HAVE_LONG_LONGS
329 protp
= SCM_SYMBOLP (prot
)
330 && (1 == SCM_SYMBOL_LENGTH (prot
))
331 && ('s' == SCM_SYMBOL_CHARS (prot
)[0]);
334 protp
= singp (prot
);
336 protp
= SCM_REALP(prot
);
338 protp
= SCM_COMPLEXP(prot
);
341 protp
= SCM_NULLP(prot
);
346 return SCM_BOOL(protp
);
352 SCM_DEFINE (scm_array_rank
, "array-rank", 1, 0, 0,
354 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
355 "not an array, @code{0} is returned.")
356 #define FUNC_NAME s_scm_array_rank
360 switch (SCM_TYP7 (ra
))
373 #ifdef HAVE_LONG_LONGS
377 return SCM_MAKINUM (1L);
380 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
387 SCM_DEFINE (scm_array_dimensions
, "array-dimensions", 1, 0, 0,
389 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
390 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
392 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
394 #define FUNC_NAME s_scm_array_dimensions
401 switch (SCM_TYP7 (ra
))
416 #ifdef HAVE_LONG_LONGS
419 return scm_cons (scm_uniform_vector_length (ra
), SCM_EOL
);
421 if (!SCM_ARRAYP (ra
))
423 k
= SCM_ARRAY_NDIM (ra
);
424 s
= SCM_ARRAY_DIMS (ra
);
426 res
= scm_cons (s
[k
].lbnd
427 ? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
),
428 SCM_MAKINUM (s
[k
].ubnd
),
430 : SCM_MAKINUM (1 + s
[k
].ubnd
),
438 SCM_DEFINE (scm_shared_array_root
, "shared-array-root", 1, 0, 0,
440 "Return the root vector of a shared array.")
441 #define FUNC_NAME s_scm_shared_array_root
443 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
444 return SCM_ARRAY_V (ra
);
449 SCM_DEFINE (scm_shared_array_offset
, "shared-array-offset", 1, 0, 0,
451 "Return the root vector index of the first element in the array.")
452 #define FUNC_NAME s_scm_shared_array_offset
454 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
455 return SCM_MAKINUM (SCM_ARRAY_BASE (ra
));
460 SCM_DEFINE (scm_shared_array_increments
, "shared-array-increments", 1, 0, 0,
462 "For each dimension, return the distance between elements in the root vector.")
463 #define FUNC_NAME s_scm_shared_array_increments
468 SCM_ASSERT (SCM_ARRAYP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
469 k
= SCM_ARRAY_NDIM (ra
);
470 s
= SCM_ARRAY_DIMS (ra
);
472 res
= scm_cons (SCM_MAKINUM (s
[k
].inc
), res
);
478 static char s_bad_ind
[] = "Bad scm_array index";
482 scm_aind (SCM ra
, SCM args
, const char *what
)
483 #define FUNC_NAME what
487 register unsigned long pos
= SCM_ARRAY_BASE (ra
);
488 register unsigned long k
= SCM_ARRAY_NDIM (ra
);
489 scm_t_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
490 if (SCM_INUMP (args
))
493 scm_error_num_args_subr (what
);
494 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
496 while (k
&& !SCM_NULLP (args
))
498 ind
= SCM_CAR (args
);
499 args
= SCM_CDR (args
);
500 if (!SCM_INUMP (ind
))
501 scm_misc_error (what
, s_bad_ind
, SCM_EOL
);
503 if (j
< s
->lbnd
|| j
> s
->ubnd
)
504 scm_out_of_range (what
, ind
);
505 pos
+= (j
- s
->lbnd
) * (s
->inc
);
509 if (k
!= 0 || !SCM_NULLP (args
))
510 scm_error_num_args_subr (what
);
518 scm_make_ra (int ndim
)
522 SCM_NEWSMOB(ra
, ((scm_t_bits
) ndim
<< 17) + scm_tc16_array
,
523 scm_gc_malloc ((sizeof (scm_t_array
) +
524 ndim
* sizeof (scm_t_array_dim
)),
526 SCM_ARRAY_V (ra
) = scm_nullvect
;
531 static char s_bad_spec
[] = "Bad scm_array dimension";
532 /* Increments will still need to be set. */
536 scm_shap2ra (SCM args
, const char *what
)
540 int ndim
= scm_ilength (args
);
542 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
544 ra
= scm_make_ra (ndim
);
545 SCM_ARRAY_BASE (ra
) = 0;
546 s
= SCM_ARRAY_DIMS (ra
);
547 for (; !SCM_NULLP (args
); s
++, args
= SCM_CDR (args
))
549 spec
= SCM_CAR (args
);
550 if (SCM_INUMP (spec
))
552 if (SCM_INUM (spec
) < 0)
553 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
555 s
->ubnd
= SCM_INUM (spec
) - 1;
560 if (!SCM_CONSP (spec
) || !SCM_INUMP (SCM_CAR (spec
)))
561 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
562 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
565 || !SCM_INUMP (SCM_CAR (sp
))
566 || !SCM_NULLP (SCM_CDR (sp
)))
567 scm_misc_error (what
, s_bad_spec
, SCM_EOL
);
568 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
575 SCM_DEFINE (scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
576 (SCM dims
, SCM prot
, SCM fill
),
577 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
578 "Create and return a uniform array or vector of type\n"
579 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
580 "length @var{length}. If @var{fill} is supplied, it's used to\n"
581 "fill the array, otherwise @var{prototype} is used.")
582 #define FUNC_NAME s_scm_dimensions_to_uniform_array
585 unsigned long rlen
= 1;
589 if (SCM_INUMP (dims
))
591 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
592 if (!SCM_UNBNDP (fill
))
593 scm_array_fill_x (answer
, fill
);
594 else if (SCM_SYMBOLP (prot
))
595 scm_array_fill_x (answer
, SCM_MAKINUM (0));
597 scm_array_fill_x (answer
, prot
);
601 SCM_ASSERT (SCM_NULLP (dims
) || SCM_CONSP (dims
),
602 dims
, SCM_ARG1
, FUNC_NAME
);
603 ra
= scm_shap2ra (dims
, FUNC_NAME
);
604 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
605 s
= SCM_ARRAY_DIMS (ra
);
606 k
= SCM_ARRAY_NDIM (ra
);
611 SCM_ASSERT_RANGE (1, dims
, s
[k
].lbnd
<= s
[k
].ubnd
);
612 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
615 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
617 if (!SCM_UNBNDP (fill
))
618 scm_array_fill_x (ra
, fill
);
619 else if (SCM_SYMBOLP (prot
))
620 scm_array_fill_x (ra
, SCM_MAKINUM (0));
622 scm_array_fill_x (ra
, prot
);
624 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
625 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
626 return SCM_ARRAY_V (ra
);
633 scm_ra_set_contp (SCM ra
)
635 size_t k
= SCM_ARRAY_NDIM (ra
);
638 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
641 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
643 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra
);
646 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
647 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
650 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra
);
654 SCM_DEFINE (scm_make_shared_array
, "make-shared-array", 2, 0, 1,
655 (SCM oldra
, SCM mapfunc
, SCM dims
),
656 "@code{make-shared-array} can be used to create shared subarrays of other\n"
657 "arrays. The @var{mapper} is a function that translates coordinates in\n"
658 "the new array into coordinates in the old array. A @var{mapper} must be\n"
659 "linear, and its range must stay within the bounds of the old array, but\n"
660 "it can be otherwise arbitrary. A simple example:\n"
662 "(define fred (make-array #f 8 8))\n"
663 "(define freds-diagonal\n"
664 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
665 "(array-set! freds-diagonal 'foo 3)\n"
666 "(array-ref fred 3 3) @result{} foo\n"
667 "(define freds-center\n"
668 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
669 "(array-ref freds-center 0 0) @result{} foo\n"
671 #define FUNC_NAME s_scm_make_shared_array
677 long old_min
, new_min
, old_max
, new_max
;
680 SCM_VALIDATE_REST_ARGUMENT (dims
);
681 SCM_VALIDATE_ARRAY (1,oldra
);
682 SCM_VALIDATE_PROC (2,mapfunc
);
683 ra
= scm_shap2ra (dims
, FUNC_NAME
);
684 if (SCM_ARRAYP (oldra
))
686 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
687 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
688 s
= SCM_ARRAY_DIMS (oldra
);
689 k
= SCM_ARRAY_NDIM (oldra
);
693 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
695 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
700 SCM_ARRAY_V (ra
) = oldra
;
702 old_max
= SCM_INUM (scm_uniform_vector_length (oldra
)) - 1;
705 s
= SCM_ARRAY_DIMS (ra
);
706 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
708 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
709 if (s
[k
].ubnd
< s
[k
].lbnd
)
711 if (1 == SCM_ARRAY_NDIM (ra
))
712 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
714 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
718 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
719 if (SCM_ARRAYP (oldra
))
720 i
= (size_t) scm_aind (oldra
, imap
, FUNC_NAME
);
723 if (SCM_NINUMP (imap
))
726 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
727 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
728 imap
= SCM_CAR (imap
);
732 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
734 k
= SCM_ARRAY_NDIM (ra
);
737 if (s
[k
].ubnd
> s
[k
].lbnd
)
739 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
740 imap
= scm_apply_0 (mapfunc
, scm_reverse (inds
));
741 if (SCM_ARRAYP (oldra
))
743 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
746 if (SCM_NINUMP (imap
))
748 if (scm_ilength (imap
) != 1 || !SCM_INUMP (SCM_CAR (imap
)))
749 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
750 imap
= SCM_CAR (imap
);
752 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
756 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
758 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
761 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
762 indptr
= SCM_CDR (indptr
);
764 if (old_min
> new_min
|| old_max
< new_max
)
765 SCM_MISC_ERROR ("mapping out of range", SCM_EOL
);
766 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
768 SCM v
= SCM_ARRAY_V (ra
);
769 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
770 if (1 == s
->inc
&& 0 == s
->lbnd
&& length
== 1 + s
->ubnd
)
772 if (s
->ubnd
< s
->lbnd
)
773 return scm_make_uve (0L, scm_array_prototype (ra
));
775 scm_ra_set_contp (ra
);
781 /* args are RA . DIMS */
782 SCM_DEFINE (scm_transpose_array
, "transpose-array", 1, 0, 1,
784 "Return an array sharing contents with @var{array}, but with\n"
785 "dimensions arranged in a different order. There must be one\n"
786 "@var{dim} argument for each dimension of @var{array}.\n"
787 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
788 "and the rank of the array to be returned. Each integer in that\n"
789 "range must appear at least once in the argument list.\n"
791 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
792 "dimensions in the array to be returned, their positions in the\n"
793 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
794 "may have the same value, in which case the returned array will\n"
795 "have smaller rank than @var{array}.\n"
798 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
799 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
800 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
801 " #2((a 4) (b 5) (c 6))\n"
803 #define FUNC_NAME s_scm_transpose_array
805 SCM res
, vargs
, *ve
= &vargs
;
806 scm_t_array_dim
*s
, *r
;
809 SCM_VALIDATE_REST_ARGUMENT (args
);
810 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
811 switch (SCM_TYP7 (ra
))
814 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
824 #ifdef HAVE_LONG_LONGS
827 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
828 SCM_WRONG_NUM_ARGS ();
829 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CAR (args
));
830 SCM_ASSERT_RANGE (SCM_ARG2
, SCM_CAR (args
),
831 SCM_EQ_P (SCM_INUM0
, SCM_CAR (args
)));
834 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
835 vargs
= scm_vector (args
);
836 if (SCM_VECTOR_LENGTH (vargs
) != SCM_ARRAY_NDIM (ra
))
837 SCM_WRONG_NUM_ARGS ();
838 ve
= SCM_VELTS (vargs
);
840 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
842 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
844 i
= SCM_INUM (ve
[k
]);
845 if (i
< 0 || i
>= SCM_ARRAY_NDIM (ra
))
846 scm_out_of_range (FUNC_NAME
, ve
[k
]);
851 res
= scm_make_ra (ndim
);
852 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
853 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
856 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
857 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
859 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
861 i
= SCM_INUM (ve
[k
]);
862 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
863 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
864 if (r
->ubnd
< r
->lbnd
)
873 if (r
->ubnd
> s
->ubnd
)
875 if (r
->lbnd
< s
->lbnd
)
877 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
884 SCM_MISC_ERROR ("bad argument list", SCM_EOL
);
885 scm_ra_set_contp (res
);
891 /* args are RA . AXES */
892 SCM_DEFINE (scm_enclose_array
, "enclose-array", 1, 0, 1,
894 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
895 "the rank of @var{array}. @var{enclose-array} returns an array\n"
896 "resembling an array of shared arrays. The dimensions of each shared\n"
897 "array are the same as the @var{dim}th dimensions of the original array,\n"
898 "the dimensions of the outer array are the same as those of the original\n"
899 "array that did not match a @var{dim}.\n\n"
900 "An enclosed array is not a general Scheme array. Its elements may not\n"
901 "be set using @code{array-set!}. Two references to the same element of\n"
902 "an enclosed array will be @code{equal?} but will not in general be\n"
903 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
904 "enclosed array is unspecified.\n\n"
907 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
908 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
909 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
910 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
912 #define FUNC_NAME s_scm_enclose_array
914 SCM axv
, res
, ra_inr
;
915 scm_t_array_dim vdim
, *s
= &vdim
;
916 int ndim
, j
, k
, ninr
, noutr
;
918 SCM_VALIDATE_REST_ARGUMENT (axes
);
919 if (SCM_NULLP (axes
))
920 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
921 ninr
= scm_ilength (axes
);
923 SCM_WRONG_NUM_ARGS ();
924 ra_inr
= scm_make_ra (ninr
);
925 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
929 badarg1
:SCM_WRONG_TYPE_ARG (1, ra
);
941 #ifdef HAVE_LONG_LONGS
945 s
->ubnd
= SCM_INUM (scm_uniform_vector_length (ra
)) - 1;
947 SCM_ARRAY_V (ra_inr
) = ra
;
948 SCM_ARRAY_BASE (ra_inr
) = 0;
952 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
953 s
= SCM_ARRAY_DIMS (ra
);
954 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
955 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
956 ndim
= SCM_ARRAY_NDIM (ra
);
961 SCM_WRONG_NUM_ARGS ();
962 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKE_CHAR (0));
963 res
= scm_make_ra (noutr
);
964 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
965 SCM_ARRAY_V (res
) = ra_inr
;
966 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
968 if (!SCM_INUMP (SCM_CAR (axes
)))
969 SCM_MISC_ERROR ("bad axis", SCM_EOL
);
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_STRING_CHARS (axv
)[j
] = 1;
976 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
978 while (SCM_STRING_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 "Return @code{#t} if its arguments would be acceptable to\n"
996 #define FUNC_NAME s_scm_array_in_bounds_p
1004 SCM_VALIDATE_REST_ARGUMENT (args
);
1005 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1006 if (SCM_NIMP (args
))
1009 ind
= SCM_CAR (args
);
1010 args
= SCM_CDR (args
);
1011 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
1012 pos
= SCM_INUM (ind
);
1018 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1019 wna
: SCM_WRONG_NUM_ARGS ();
1021 k
= SCM_ARRAY_NDIM (v
);
1022 s
= SCM_ARRAY_DIMS (v
);
1023 pos
= SCM_ARRAY_BASE (v
);
1026 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1033 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1035 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1038 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1039 if (!(--k
&& SCM_NIMP (args
)))
1041 ind
= SCM_CAR (args
);
1042 args
= SCM_CDR (args
);
1044 if (!SCM_INUMP (ind
))
1045 SCM_MISC_ERROR (s_bad_ind
, SCM_EOL
);
1047 SCM_ASRTGO (0 == k
, wna
);
1048 v
= SCM_ARRAY_V (v
);
1051 case scm_tc7_string
:
1052 case scm_tc7_byvect
:
1059 #ifdef HAVE_LONG_LONGS
1060 case scm_tc7_llvect
:
1062 case scm_tc7_vector
:
1065 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1066 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1067 return SCM_BOOL(pos
>= 0 && pos
< length
);
1074 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1077 SCM_DEFINE (scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
1079 "@deffnx {Scheme Procedure} array-ref v . args\n"
1080 "Return the element at the @code{(index1, index2)} element in\n"
1082 #define FUNC_NAME s_scm_uniform_vector_ref
1088 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1091 else if (SCM_ARRAYP (v
))
1093 pos
= scm_aind (v
, args
, FUNC_NAME
);
1094 v
= SCM_ARRAY_V (v
);
1098 unsigned long int length
;
1099 if (SCM_NIMP (args
))
1101 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1102 pos
= SCM_INUM (SCM_CAR (args
));
1103 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1107 SCM_VALIDATE_INUM (2,args
);
1108 pos
= SCM_INUM (args
);
1110 length
= SCM_INUM (scm_uniform_vector_length (v
));
1111 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1116 if (SCM_NULLP (args
))
1119 SCM_WRONG_TYPE_ARG (1, v
);
1123 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1125 SCM_WRONG_NUM_ARGS ();
1128 int k
= SCM_ARRAY_NDIM (v
);
1129 SCM res
= scm_make_ra (k
);
1130 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1131 SCM_ARRAY_BASE (res
) = pos
;
1134 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1135 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1136 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1141 if (SCM_BITVEC_REF (v
, pos
))
1145 case scm_tc7_string
:
1146 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1147 case scm_tc7_byvect
:
1148 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1150 return scm_ulong2num (((unsigned long *) SCM_VELTS (v
))[pos
]);
1152 return scm_long2num (((signed long *) SCM_VELTS (v
))[pos
]);
1155 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1156 #ifdef HAVE_LONG_LONGS
1157 case scm_tc7_llvect
:
1158 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1162 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1164 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1166 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1167 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1168 case scm_tc7_vector
:
1170 return SCM_VELTS (v
)[pos
];
1175 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1176 tries to recycle conses. (Make *sure* you want them recycled.) */
1179 scm_cvref (SCM v
, unsigned long pos
, SCM last
)
1180 #define FUNC_NAME "scm_cvref"
1185 SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1187 if (SCM_BITVEC_REF(v
,pos
))
1191 case scm_tc7_string
:
1192 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v
)[pos
]);
1193 case scm_tc7_byvect
:
1194 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v
))[pos
]);
1196 return scm_ulong2num(((unsigned long *) SCM_VELTS (v
))[pos
]);
1198 return scm_long2num(((signed long *) SCM_VELTS (v
))[pos
]);
1200 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v
))[pos
]);
1201 #ifdef HAVE_LONG_LONGS
1202 case scm_tc7_llvect
:
1203 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v
))[pos
]);
1206 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1208 SCM_REAL_VALUE (last
) = ((float *) SCM_CELL_WORD_1 (v
))[pos
];
1211 return scm_make_real (((float *) SCM_CELL_WORD_1 (v
))[pos
]);
1213 if (SCM_NIMP (last
) && !SCM_EQ_P (last
, scm_flo0
) && SCM_SLOPPY_REALP (last
))
1215 SCM_REAL_VALUE (last
) = ((double *) SCM_CELL_WORD_1 (v
))[pos
];
1218 return scm_make_real (((double *) SCM_CELL_WORD_1 (v
))[pos
]);
1220 if (SCM_NIMP (last
) && SCM_SLOPPY_COMPLEXP (last
))
1222 SCM_COMPLEX_REAL (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
];
1223 SCM_COMPLEX_IMAG (last
) = ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1];
1226 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v
))[2 * pos
],
1227 ((double *) SCM_CELL_WORD_1 (v
))[2 * pos
+ 1]);
1228 case scm_tc7_vector
:
1230 return SCM_VELTS (v
)[pos
];
1232 { /* enclosed scm_array */
1233 int k
= SCM_ARRAY_NDIM (v
);
1234 SCM res
= scm_make_ra (k
);
1235 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1236 SCM_ARRAY_BASE (res
) = pos
;
1239 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1240 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1241 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1250 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1253 /* Note that args may be a list or an immediate object, depending which
1254 PROC is used (and it's called from C too). */
1255 SCM_DEFINE (scm_array_set_x
, "array-set!", 2, 0, 1,
1256 (SCM v
, SCM obj
, SCM args
),
1257 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1258 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1259 "@var{new-value}. The value returned by array-set! is unspecified.")
1260 #define FUNC_NAME s_scm_array_set_x
1264 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1267 pos
= scm_aind (v
, args
, FUNC_NAME
);
1268 v
= SCM_ARRAY_V (v
);
1272 unsigned long int length
;
1273 if (SCM_CONSP (args
))
1275 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG3
, FUNC_NAME
);
1276 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1277 pos
= SCM_INUM (SCM_CAR (args
));
1281 SCM_VALIDATE_INUM_COPY (3,args
,pos
);
1283 length
= SCM_INUM (scm_uniform_vector_length (v
));
1284 SCM_ASRTGO (pos
>= 0 && pos
< length
, outrng
);
1286 switch (SCM_TYP7 (v
))
1289 SCM_WRONG_TYPE_ARG (1, v
);
1292 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1294 SCM_WRONG_NUM_ARGS ();
1295 case scm_tc7_smob
: /* enclosed */
1298 if (SCM_FALSEP (obj
))
1299 SCM_BITVEC_CLR(v
,pos
);
1300 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1301 SCM_BITVEC_SET(v
,pos
);
1303 badobj
:SCM_WRONG_TYPE_ARG (2, obj
);
1305 case scm_tc7_string
:
1306 SCM_ASRTGO (SCM_CHARP (obj
), badobj
);
1307 SCM_STRING_UCHARS (v
)[pos
] = SCM_CHAR (obj
);
1309 case scm_tc7_byvect
:
1310 if (SCM_CHARP (obj
))
1311 obj
= SCM_MAKINUM ((char) SCM_CHAR (obj
));
1312 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1313 ((char *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1316 ((unsigned long *) SCM_UVECTOR_BASE (v
))[pos
]
1317 = scm_num2ulong (obj
, SCM_ARG2
, FUNC_NAME
);
1320 ((long *) SCM_UVECTOR_BASE (v
))[pos
]
1321 = scm_num2long (obj
, SCM_ARG2
, FUNC_NAME
);
1324 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1325 ((short *) SCM_UVECTOR_BASE (v
))[pos
] = SCM_INUM (obj
);
1327 #ifdef HAVE_LONG_LONGS
1328 case scm_tc7_llvect
:
1329 ((long long *) SCM_UVECTOR_BASE (v
))[pos
]
1330 = scm_num2long_long (obj
, SCM_ARG2
, FUNC_NAME
);
1334 ((float *) SCM_UVECTOR_BASE (v
))[pos
]
1335 = (float) scm_num2dbl (obj
, FUNC_NAME
);
1338 ((double *) SCM_UVECTOR_BASE (v
))[pos
]
1339 = scm_num2dbl (obj
, FUNC_NAME
);
1342 SCM_ASRTGO (SCM_INEXACTP (obj
), badobj
);
1343 if (SCM_REALP (obj
)) {
1344 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_REAL_VALUE (obj
);
1345 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = 0.0;
1347 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
] = SCM_COMPLEX_REAL (obj
);
1348 ((double *) SCM_UVECTOR_BASE (v
))[2 * pos
+ 1] = SCM_COMPLEX_IMAG (obj
);
1351 case scm_tc7_vector
:
1353 SCM_VELTS (v
)[pos
] = obj
;
1356 return SCM_UNSPECIFIED
;
1360 /* attempts to unroll an array into a one-dimensional array.
1361 returns the unrolled array or #f if it can't be done. */
1362 /* if strict is not SCM_UNDEFINED, return #f if returned array
1363 wouldn't have contiguous elements. */
1364 SCM_DEFINE (scm_array_contents
, "array-contents", 1, 1, 0,
1365 (SCM ra
, SCM strict
),
1366 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1367 "without changing their order (last subscript changing fastest), then\n"
1368 "@code{array-contents} returns that shared array, otherwise it returns\n"
1369 "@code{#f}. All arrays made by @var{make-array} and\n"
1370 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1371 "@var{make-shared-array} may not be.\n\n"
1372 "If the optional argument @var{strict} is provided, a shared array will\n"
1373 "be returned only if its elements are stored internally contiguous in\n"
1375 #define FUNC_NAME s_scm_array_contents
1380 switch SCM_TYP7 (ra
)
1384 case scm_tc7_vector
:
1386 case scm_tc7_string
:
1388 case scm_tc7_byvect
:
1395 #ifdef HAVE_LONG_LONGS
1396 case scm_tc7_llvect
:
1401 size_t k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1402 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1404 for (k
= 0; k
< ndim
; k
++)
1405 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1406 if (!SCM_UNBNDP (strict
))
1408 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1410 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1412 if (len
!= SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) ||
1413 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1420 SCM v
= SCM_ARRAY_V (ra
);
1421 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (v
));
1422 if ((len
== length
) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1426 sra
= scm_make_ra (1);
1427 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1428 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1429 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1430 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1431 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1440 scm_ra2contig (SCM ra
, int copy
)
1445 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1446 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1447 k
= SCM_ARRAY_NDIM (ra
);
1448 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1450 if (scm_tc7_bvect
!= SCM_TYP7 (SCM_ARRAY_V (ra
)))
1452 if ((len
== SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra
)) &&
1453 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1454 0 == len
% SCM_LONG_BIT
))
1457 ret
= scm_make_ra (k
);
1458 SCM_ARRAY_BASE (ret
) = 0;
1461 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1462 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1463 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1464 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1466 SCM_ARRAY_V (ret
) = scm_make_uve (inc
, scm_array_prototype (ra
));
1468 scm_array_copy_x (ra
, ret
);
1474 SCM_DEFINE (scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1475 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1476 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1477 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1478 "binary objects from @var{port-or-fdes}.\n"
1479 "If an end of file is encountered,\n"
1480 "the objects up to that point are put into @var{ura}\n"
1481 "(starting at the beginning) and the remainder of the array is\n"
1483 "The optional arguments @var{start} and @var{end} allow\n"
1484 "a specified region of a vector (or linearized array) to be read,\n"
1485 "leaving the remainder of the vector unchanged.\n\n"
1486 "@code{uniform-array-read!} returns the number of objects read.\n"
1487 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1488 "returned by @code{(current-input-port)}.")
1489 #define FUNC_NAME s_scm_uniform_array_read_x
1491 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1498 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1499 if (SCM_UNBNDP (port_or_fd
))
1500 port_or_fd
= scm_cur_inp
;
1502 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1503 || (SCM_OPINPORTP (port_or_fd
)),
1504 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1505 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1507 : SCM_INUM (scm_uniform_vector_length (v
)));
1513 badarg1
:SCM_WRONG_TYPE_ARG (SCM_ARG1
, v
);
1515 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1516 cra
= scm_ra2contig (ra
, 0);
1517 cstart
+= SCM_ARRAY_BASE (cra
);
1518 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1519 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1520 v
= SCM_ARRAY_V (cra
);
1522 case scm_tc7_string
:
1523 base
= SCM_STRING_CHARS (v
);
1527 base
= (char *) SCM_BITVECTOR_BASE (v
);
1528 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1529 cstart
/= SCM_LONG_BIT
;
1532 case scm_tc7_byvect
:
1533 base
= (char *) SCM_UVECTOR_BASE (v
);
1538 base
= (char *) SCM_UVECTOR_BASE (v
);
1542 base
= (char *) SCM_UVECTOR_BASE (v
);
1543 sz
= sizeof (short);
1545 #ifdef HAVE_LONG_LONGS
1546 case scm_tc7_llvect
:
1547 base
= (char *) SCM_UVECTOR_BASE (v
);
1548 sz
= sizeof (long long);
1552 base
= (char *) SCM_UVECTOR_BASE (v
);
1553 sz
= sizeof (float);
1556 base
= (char *) SCM_UVECTOR_BASE (v
);
1557 sz
= sizeof (double);
1560 base
= (char *) SCM_UVECTOR_BASE (v
);
1561 sz
= 2 * sizeof (double);
1566 if (!SCM_UNBNDP (start
))
1569 SCM_NUM2LONG (3, start
);
1571 if (offset
< 0 || offset
>= cend
)
1572 scm_out_of_range (FUNC_NAME
, start
);
1574 if (!SCM_UNBNDP (end
))
1577 SCM_NUM2LONG (4, end
);
1579 if (tend
<= offset
|| tend
> cend
)
1580 scm_out_of_range (FUNC_NAME
, end
);
1585 if (SCM_NIMP (port_or_fd
))
1587 scm_t_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1588 int remaining
= (cend
- offset
) * sz
;
1589 char *dest
= base
+ (cstart
+ offset
) * sz
;
1591 if (pt
->rw_active
== SCM_PORT_WRITE
)
1592 scm_flush (port_or_fd
);
1594 ans
= cend
- offset
;
1595 while (remaining
> 0)
1597 if (pt
->read_pos
< pt
->read_end
)
1599 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1602 memcpy (dest
, pt
->read_pos
, to_copy
);
1603 pt
->read_pos
+= to_copy
;
1604 remaining
-= to_copy
;
1609 if (scm_fill_input (port_or_fd
) == EOF
)
1611 if (remaining
% sz
!= 0)
1613 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL
);
1615 ans
-= remaining
/ sz
;
1622 pt
->rw_active
= SCM_PORT_READ
;
1624 else /* file descriptor. */
1626 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1627 base
+ (cstart
+ offset
) * sz
,
1628 (sz
* (cend
- offset
))));
1632 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1633 ans
*= SCM_LONG_BIT
;
1635 if (!SCM_EQ_P (v
, ra
) && !SCM_EQ_P (cra
, ra
))
1636 scm_array_copy_x (cra
, ra
);
1638 return SCM_MAKINUM (ans
);
1642 SCM_DEFINE (scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1643 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1644 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1645 "Writes all elements of @var{ura} as binary objects to\n"
1646 "@var{port-or-fdes}.\n\n"
1647 "The optional arguments @var{start}\n"
1648 "and @var{end} allow\n"
1649 "a specified region of a vector (or linearized array) to be written.\n\n"
1650 "The number of objects actually written is returned.\n"
1651 "@var{port-or-fdes} may be\n"
1652 "omitted, in which case it defaults to the value returned by\n"
1653 "@code{(current-output-port)}.")
1654 #define FUNC_NAME s_scm_uniform_array_write
1662 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1664 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1665 if (SCM_UNBNDP (port_or_fd
))
1666 port_or_fd
= scm_cur_outp
;
1668 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1669 || (SCM_OPOUTPORTP (port_or_fd
)),
1670 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1671 vlen
= (SCM_TYP7 (v
) == scm_tc7_smob
1673 : SCM_INUM (scm_uniform_vector_length (v
)));
1679 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
1681 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1682 v
= scm_ra2contig (v
, 1);
1683 cstart
= SCM_ARRAY_BASE (v
);
1684 vlen
= (SCM_ARRAY_DIMS (v
)->inc
1685 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1));
1686 v
= SCM_ARRAY_V (v
);
1688 case scm_tc7_string
:
1689 base
= SCM_STRING_CHARS (v
);
1693 base
= (char *) SCM_BITVECTOR_BASE (v
);
1694 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1695 cstart
/= SCM_LONG_BIT
;
1698 case scm_tc7_byvect
:
1699 base
= (char *) SCM_UVECTOR_BASE (v
);
1704 base
= (char *) SCM_UVECTOR_BASE (v
);
1708 base
= (char *) SCM_UVECTOR_BASE (v
);
1709 sz
= sizeof (short);
1711 #ifdef HAVE_LONG_LONGS
1712 case scm_tc7_llvect
:
1713 base
= (char *) SCM_UVECTOR_BASE (v
);
1714 sz
= sizeof (long long);
1718 base
= (char *) SCM_UVECTOR_BASE (v
);
1719 sz
= sizeof (float);
1722 base
= (char *) SCM_UVECTOR_BASE (v
);
1723 sz
= sizeof (double);
1726 base
= (char *) SCM_UVECTOR_BASE (v
);
1727 sz
= 2 * sizeof (double);
1732 if (!SCM_UNBNDP (start
))
1735 SCM_NUM2LONG (3, start
);
1737 if (offset
< 0 || offset
>= cend
)
1738 scm_out_of_range (FUNC_NAME
, start
);
1740 if (!SCM_UNBNDP (end
))
1743 SCM_NUM2LONG (4, end
);
1745 if (tend
<= offset
|| tend
> cend
)
1746 scm_out_of_range (FUNC_NAME
, end
);
1751 if (SCM_NIMP (port_or_fd
))
1753 char *source
= base
+ (cstart
+ offset
) * sz
;
1755 ans
= cend
- offset
;
1756 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1758 else /* file descriptor. */
1760 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1761 base
+ (cstart
+ offset
) * sz
,
1762 (sz
* (cend
- offset
))));
1766 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1767 ans
*= SCM_LONG_BIT
;
1769 return SCM_MAKINUM (ans
);
1774 static char cnt_tab
[16] =
1775 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1777 SCM_DEFINE (scm_bit_count
, "bit-count", 2, 0, 0,
1778 (SCM b
, SCM bitvector
),
1779 "Return the number of occurrences of the boolean @var{b} in\n"
1781 #define FUNC_NAME s_scm_bit_count
1783 SCM_VALIDATE_BOOL (1, b
);
1784 SCM_ASSERT (SCM_BITVECTOR_P (bitvector
), bitvector
, 2, FUNC_NAME
);
1785 if (SCM_BITVECTOR_LENGTH (bitvector
) == 0) {
1788 unsigned long int count
= 0;
1789 unsigned long int i
= (SCM_BITVECTOR_LENGTH (bitvector
) - 1) / SCM_LONG_BIT
;
1790 unsigned long int w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1791 if (SCM_FALSEP (b
)) {
1794 w
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (bitvector
) - 1) % SCM_LONG_BIT
);
1797 count
+= cnt_tab
[w
& 0x0f];
1801 return SCM_MAKINUM (count
);
1804 w
= SCM_UNPACK (SCM_VELTS (bitvector
)[i
]);
1805 if (SCM_FALSEP (b
)) {
1815 SCM_DEFINE (scm_bit_position
, "bit-position", 3, 0, 0,
1816 (SCM item
, SCM v
, SCM k
),
1817 "Return the minimum index of an occurrence of @var{bool} in\n"
1818 "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
1819 "within the specified range @code{#f} is returned.")
1820 #define FUNC_NAME s_scm_bit_position
1822 long i
, lenw
, xbits
, pos
;
1823 register unsigned long w
;
1825 SCM_VALIDATE_BOOL (1, item
);
1826 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG2
, FUNC_NAME
);
1827 SCM_VALIDATE_INUM_COPY (3,k
,pos
);
1828 SCM_ASSERT_RANGE (3, k
, (pos
<= SCM_BITVECTOR_LENGTH (v
)) && (pos
>= 0));
1830 if (pos
== SCM_BITVECTOR_LENGTH (v
))
1833 lenw
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1834 i
= pos
/ SCM_LONG_BIT
;
1835 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1836 if (SCM_FALSEP (item
))
1838 xbits
= (pos
% SCM_LONG_BIT
);
1840 w
= ((w
>> xbits
) << xbits
);
1841 xbits
= SCM_LONG_BIT
- 1 - (SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1844 if (w
&& (i
== lenw
))
1845 w
= ((w
<< xbits
) >> xbits
);
1851 return SCM_MAKINUM (pos
);
1856 return SCM_MAKINUM (pos
+ 1);
1859 return SCM_MAKINUM (pos
+ 2);
1861 return SCM_MAKINUM (pos
+ 3);
1868 pos
+= SCM_LONG_BIT
;
1869 w
= SCM_UNPACK (SCM_VELTS (v
)[i
]);
1870 if (SCM_FALSEP (item
))
1878 SCM_DEFINE (scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1879 (SCM v
, SCM kv
, SCM obj
),
1880 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1881 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1882 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1883 "AND'ed into @var{bv}.\n\n"
1884 "If uve is a unsigned long integer vector all the elements of uve\n"
1885 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1886 "of @var{bv} corresponding to the indexes in uve are set to\n"
1887 "@var{bool}. The return value is unspecified.")
1888 #define FUNC_NAME s_scm_bit_set_star_x
1890 register long i
, k
, vlen
;
1891 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1892 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1893 switch SCM_TYP7 (kv
)
1896 badarg2
:SCM_WRONG_TYPE_ARG (2, kv
);
1898 vlen
= SCM_BITVECTOR_LENGTH (v
);
1899 if (SCM_FALSEP (obj
))
1900 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1902 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1904 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1905 SCM_BITVEC_CLR(v
,k
);
1907 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1908 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1910 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1912 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1913 SCM_BITVEC_SET(v
,k
);
1916 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1919 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1920 if (SCM_FALSEP (obj
))
1921 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1922 SCM_BITVECTOR_BASE (v
) [k
] &= ~SCM_BITVECTOR_BASE (kv
) [k
];
1923 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1924 for (k
= (SCM_BITVECTOR_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1925 SCM_BITVECTOR_BASE (v
) [k
] |= SCM_BITVECTOR_BASE (kv
) [k
];
1930 return SCM_UNSPECIFIED
;
1935 SCM_DEFINE (scm_bit_count_star
, "bit-count*", 3, 0, 0,
1936 (SCM v
, SCM kv
, SCM obj
),
1939 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1941 "@var{bv} is not modified.")
1942 #define FUNC_NAME s_scm_bit_count_star
1944 register long i
, vlen
, count
= 0;
1945 register unsigned long k
;
1948 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
1949 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1950 switch SCM_TYP7 (kv
)
1954 SCM_WRONG_TYPE_ARG (2, kv
);
1956 vlen
= SCM_BITVECTOR_LENGTH (v
);
1957 if (SCM_FALSEP (obj
))
1958 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1960 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1962 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1963 if (!SCM_BITVEC_REF(v
,k
))
1966 else if (SCM_EQ_P (obj
, SCM_BOOL_T
))
1967 for (i
= SCM_UVECTOR_LENGTH (kv
); i
;)
1969 k
= SCM_UNPACK (SCM_VELTS (kv
)[--i
]);
1971 scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (k
));
1972 if (SCM_BITVEC_REF (v
,k
))
1976 badarg3
:SCM_WRONG_TYPE_ARG (3, obj
);
1979 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v
) == SCM_BITVECTOR_LENGTH (kv
), v
, SCM_ARG1
, FUNC_NAME
);
1980 if (0 == SCM_BITVECTOR_LENGTH (v
))
1982 SCM_ASRTGO (SCM_BOOLP (obj
), badarg3
);
1983 fObj
= SCM_EQ_P (obj
, SCM_BOOL_T
);
1984 i
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1985 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK (SCM_VELTS (v
)[i
]) : ~ SCM_UNPACK (SCM_VELTS (v
)[i
]));
1986 k
<<= SCM_LONG_BIT
- 1 - ((SCM_BITVECTOR_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1990 count
+= cnt_tab
[k
& 0x0f];
1992 return SCM_MAKINUM (count
);
1994 /* urg. repetitive (see above.) */
1995 k
= SCM_UNPACK (SCM_VELTS (kv
)[i
]) & (fObj
? SCM_UNPACK(SCM_VELTS (v
)[i
]) : ~SCM_UNPACK (SCM_VELTS (v
)[i
]));
1998 return SCM_MAKINUM (count
);
2003 SCM_DEFINE (scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
2005 "Modify @var{bv} by replacing each element with its negation.")
2006 #define FUNC_NAME s_scm_bit_invert_x
2010 SCM_ASSERT (SCM_BITVECTOR_P (v
), v
, SCM_ARG1
, FUNC_NAME
);
2012 k
= SCM_BITVECTOR_LENGTH (v
);
2013 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
2014 SCM_BITVECTOR_BASE (v
) [k
] = ~SCM_BITVECTOR_BASE (v
) [k
];
2016 return SCM_UNSPECIFIED
;
2022 scm_istr2bve (char *str
, long len
)
2024 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
2025 long *data
= (long *) SCM_VELTS (v
);
2026 register unsigned long mask
;
2029 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
2032 j
= len
- k
* SCM_LONG_BIT
;
2033 if (j
> SCM_LONG_BIT
)
2035 for (mask
= 1L; j
--; mask
<<= 1)
2053 ra2l (SCM ra
,unsigned long base
,unsigned long k
)
2055 register SCM res
= SCM_EOL
;
2056 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2058 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2060 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2061 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2066 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2074 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2081 SCM_DEFINE (scm_array_to_list
, "array->list", 1, 0, 0,
2083 "Return a list consisting of all the elements, in order, of\n"
2085 #define FUNC_NAME s_scm_array_to_list
2089 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2093 badarg1
:SCM_WRONG_TYPE_ARG (1, v
);
2095 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2096 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2097 case scm_tc7_vector
:
2099 return scm_vector_to_list (v
);
2100 case scm_tc7_string
:
2101 return scm_string_to_list (v
);
2104 long *data
= (long *) SCM_VELTS (v
);
2105 register unsigned long mask
;
2106 for (k
= (SCM_BITVECTOR_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2107 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2108 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2109 for (mask
= 1L << ((SCM_BITVECTOR_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2110 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
2113 case scm_tc7_byvect
:
2115 signed char *data
= (signed char *) SCM_VELTS (v
);
2116 unsigned long k
= SCM_UVECTOR_LENGTH (v
);
2118 res
= scm_cons (SCM_MAKINUM (data
[--k
]), res
);
2123 long *data
= (long *)SCM_VELTS(v
);
2124 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2125 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2130 long *data
= (long *)SCM_VELTS(v
);
2131 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2132 res
= scm_cons(scm_long2num(data
[k
]), res
);
2137 short *data
= (short *)SCM_VELTS(v
);
2138 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2139 res
= scm_cons(scm_short2num (data
[k
]), res
);
2142 #ifdef HAVE_LONG_LONGS
2143 case scm_tc7_llvect
:
2145 long long *data
= (long long *)SCM_VELTS(v
);
2146 for (k
= SCM_UVECTOR_LENGTH(v
) - 1; k
>= 0; k
--)
2147 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2153 float *data
= (float *) SCM_VELTS (v
);
2154 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2155 res
= scm_cons (scm_make_real (data
[k
]), res
);
2160 double *data
= (double *) SCM_VELTS (v
);
2161 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2162 res
= scm_cons (scm_make_real (data
[k
]), res
);
2167 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2168 for (k
= SCM_UVECTOR_LENGTH (v
) - 1; k
>= 0; k
--)
2169 res
= scm_cons (scm_make_complex (data
[k
][0], data
[k
][1]), res
);
2177 static int l2ra(SCM lst
, SCM ra
, unsigned long base
, unsigned long k
);
2179 SCM_DEFINE (scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2180 (SCM ndim
, SCM prot
, SCM lst
),
2181 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2182 "Return a uniform array of the type indicated by prototype\n"
2183 "@var{prot} with elements the same as those of @var{lst}.\n"
2184 "Elements must be of the appropriate type, no coercions are\n"
2186 #define FUNC_NAME s_scm_list_to_uniform_array
2193 SCM_VALIDATE_INUM_COPY (1,ndim
,k
);
2196 n
= scm_ilength (row
);
2197 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2198 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2200 row
= SCM_CAR (row
);
2202 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2204 if (SCM_NULLP (shp
))
2206 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2207 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2210 if (!SCM_ARRAYP (ra
))
2212 unsigned long int length
= SCM_INUM (scm_uniform_vector_length (ra
));
2213 for (k
= 0; k
< length
; k
++, lst
= SCM_CDR (lst
))
2214 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2217 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2220 badlst
:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2226 l2ra (SCM lst
, SCM ra
, unsigned long base
, unsigned long k
)
2228 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2229 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2232 return (SCM_NULLP (lst
));
2233 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2237 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2239 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2241 lst
= SCM_CDR (lst
);
2243 if (SCM_NNULLP (lst
))
2250 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2252 scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2254 lst
= SCM_CDR (lst
);
2256 if (SCM_NNULLP (lst
))
2264 rapr1 (SCM ra
,unsigned long j
,unsigned long k
,SCM port
,scm_print_state
*pstate
)
2267 long n
= (SCM_TYP7 (ra
) == scm_tc7_smob
2269 : SCM_INUM (scm_uniform_vector_length (ra
)));
2272 switch SCM_TYP7 (ra
)
2277 SCM_ARRAY_BASE (ra
) = j
;
2279 scm_iprin1 (ra
, port
, pstate
);
2280 for (j
+= inc
; n
-- > 0; j
+= inc
)
2282 scm_putc (' ', port
);
2283 SCM_ARRAY_BASE (ra
) = j
;
2284 scm_iprin1 (ra
, port
, pstate
);
2288 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2291 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2292 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2294 scm_putc ('(', port
);
2295 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2296 scm_puts (") ", port
);
2299 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2300 { /* could be zero size. */
2301 scm_putc ('(', port
);
2302 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2303 scm_putc (')', port
);
2307 if (SCM_ARRAY_NDIM (ra
) > 0)
2308 { /* Could be zero-dimensional */
2309 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2310 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2314 ra
= SCM_ARRAY_V (ra
);
2317 /* scm_tc7_bvect and scm_tc7_llvect only? */
2319 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2320 for (j
+= inc
; n
-- > 0; j
+= inc
)
2322 scm_putc (' ', port
);
2323 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2326 case scm_tc7_string
:
2328 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2329 if (SCM_WRITINGP (pstate
))
2330 for (j
+= inc
; n
-- > 0; j
+= inc
)
2332 scm_putc (' ', port
);
2333 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra
)[j
]), port
, pstate
);
2336 for (j
+= inc
; n
-- > 0; j
+= inc
)
2337 scm_putc (SCM_STRING_CHARS (ra
)[j
], port
);
2339 case scm_tc7_byvect
:
2341 scm_intprint (((char *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2342 for (j
+= inc
; n
-- > 0; j
+= inc
)
2344 scm_putc (' ', port
);
2345 scm_intprint (((char *)SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2355 /* intprint can't handle >= 2^31. */
2356 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2357 scm_puts (str
, port
);
2359 for (j
+= inc
; n
-- > 0; j
+= inc
)
2361 scm_putc (' ', port
);
2362 sprintf (str
, "%lu", ((unsigned long *) SCM_VELTS (ra
))[j
]);
2363 scm_puts (str
, port
);
2368 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2369 for (j
+= inc
; n
-- > 0; j
+= inc
)
2371 scm_putc (' ', port
);
2372 scm_intprint (((signed long *) SCM_VELTS (ra
))[j
], 10, port
);
2378 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2379 for (j
+= inc
; n
-- > 0; j
+= inc
)
2381 scm_putc (' ', port
);
2382 scm_intprint (((short *) SCM_CELL_WORD_1 (ra
))[j
], 10, port
);
2389 SCM z
= scm_make_real (1.0);
2390 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2391 scm_print_real (z
, port
, pstate
);
2392 for (j
+= inc
; n
-- > 0; j
+= inc
)
2394 scm_putc (' ', port
);
2395 SCM_REAL_VALUE (z
) = ((float *) SCM_VELTS (ra
))[j
];
2396 scm_print_real (z
, port
, pstate
);
2403 SCM z
= scm_make_real (1.0 / 3.0);
2404 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2405 scm_print_real (z
, port
, pstate
);
2406 for (j
+= inc
; n
-- > 0; j
+= inc
)
2408 scm_putc (' ', port
);
2409 SCM_REAL_VALUE (z
) = ((double *) SCM_VELTS (ra
))[j
];
2410 scm_print_real (z
, port
, pstate
);
2417 SCM cz
= scm_make_complex (0.0, 1.0), z
= scm_make_real (1.0 / 3.0);
2418 SCM_REAL_VALUE (z
) =
2419 SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2420 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2421 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2423 for (j
+= inc
; n
-- > 0; j
+= inc
)
2425 scm_putc (' ', port
);
2427 = SCM_COMPLEX_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2428 SCM_COMPLEX_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2429 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz
) ? z
: cz
),
2440 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2443 unsigned long base
= 0;
2444 scm_putc ('#', port
);
2450 long ndim
= SCM_ARRAY_NDIM (v
);
2451 base
= SCM_ARRAY_BASE (v
);
2452 v
= SCM_ARRAY_V (v
);
2456 scm_puts ("<enclosed-array ", port
);
2457 rapr1 (exp
, base
, 0, port
, pstate
);
2458 scm_putc ('>', port
);
2463 scm_intprint (ndim
, 10, port
);
2468 if (SCM_EQ_P (exp
, v
))
2469 { /* a uve, not an scm_array */
2470 register long i
, j
, w
;
2471 scm_putc ('*', port
);
2472 for (i
= 0; i
< (SCM_BITVECTOR_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2474 scm_t_bits w
= SCM_UNPACK (SCM_VELTS (exp
)[i
]);
2475 for (j
= SCM_LONG_BIT
; j
; j
--)
2477 scm_putc (w
& 1 ? '1' : '0', port
);
2481 j
= SCM_BITVECTOR_LENGTH (exp
) % SCM_LONG_BIT
;
2484 w
= SCM_UNPACK (SCM_VELTS (exp
)[SCM_BITVECTOR_LENGTH (exp
) / SCM_LONG_BIT
]);
2487 scm_putc (w
& 1 ? '1' : '0', port
);
2494 scm_putc ('b', port
);
2496 case scm_tc7_string
:
2497 scm_putc ('a', port
);
2499 case scm_tc7_byvect
:
2500 scm_putc ('y', port
);
2503 scm_putc ('u', port
);
2506 scm_putc ('e', port
);
2509 scm_putc ('h', port
);
2511 #ifdef HAVE_LONG_LONGS
2512 case scm_tc7_llvect
:
2513 scm_putc ('l', port
);
2517 scm_putc ('s', port
);
2520 scm_putc ('i', port
);
2523 scm_putc ('c', port
);
2526 scm_putc ('(', port
);
2527 rapr1 (exp
, base
, 0, port
, pstate
);
2528 scm_putc (')', port
);
2532 SCM_DEFINE (scm_array_prototype
, "array-prototype", 1, 0, 0,
2534 "Return an object that would produce an array of the same type\n"
2535 "as @var{array}, if used as the @var{prototype} for\n"
2536 "@code{make-uniform-array}.")
2537 #define FUNC_NAME s_scm_array_prototype
2540 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2542 switch SCM_TYP7 (ra
)
2545 badarg
:SCM_WRONG_TYPE_ARG (1, ra
);
2547 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2549 return SCM_UNSPECIFIED
;
2550 ra
= SCM_ARRAY_V (ra
);
2552 case scm_tc7_vector
:
2557 case scm_tc7_string
:
2558 return SCM_MAKE_CHAR ('a');
2559 case scm_tc7_byvect
:
2560 return SCM_MAKE_CHAR ('\0');
2562 return SCM_MAKINUM (1L);
2564 return SCM_MAKINUM (-1L);
2566 return scm_str2symbol ("s");
2567 #ifdef HAVE_LONG_LONGS
2568 case scm_tc7_llvect
:
2569 return scm_str2symbol ("l");
2572 return scm_make_real (1.0);
2574 return scm_make_real (1.0 / 3.0);
2576 return scm_make_complex (0.0, 1.0);
2583 array_mark (SCM ptr
)
2585 return SCM_ARRAY_V (ptr
);
2590 array_free (SCM ptr
)
2592 scm_gc_free (SCM_ARRAY_MEM (ptr
),
2593 (sizeof (scm_t_array
)
2594 + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_t_array_dim
)),
2602 scm_tc16_array
= scm_make_smob_type ("array", 0);
2603 scm_set_smob_mark (scm_tc16_array
, array_mark
);
2604 scm_set_smob_free (scm_tc16_array
, array_free
);
2605 scm_set_smob_print (scm_tc16_array
, scm_raprin1
);
2606 scm_set_smob_equalp (scm_tc16_array
, scm_array_equal_p
);
2607 scm_add_feature ("array");
2608 #ifndef SCM_MAGIC_SNARFER
2609 #include "libguile/unif.x"