1 /* Copyright (C) 1995,1996,1997 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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
49 #include "sequences.h"
61 /* The set of uniform scm_vector types is:
63 * unsigned char string
70 * complex double cvect
78 * This complicates things too much if allowed on any array.
79 * C code can safely call it on arrays known to be used in a single
82 * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
84 static char s_vector_set_length_x
[] = "vector-set-length!";
88 scm_vector_set_length_x (vect
, len
)
97 SCM_ASRTGO (SCM_NIMP (vect
), badarg1
);
98 switch (SCM_TYP7 (vect
))
101 badarg1
: scm_wta (vect
, (char *) SCM_ARG1
, s_vector_set_length_x
);
103 case scm_tc7_mb_string
:
104 SCM_ASRTGO (vect
!= scm_nullstr
, badarg1
);
109 SCM_ASRTGO (vect
!= scm_nullvect
, badarg1
);
114 l
= (l
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
128 sz
= sizeof (long_long
);
139 sz
= sizeof (double);
142 sz
= 2 * sizeof (double);
147 SCM_ASSERT (SCM_INUMP (len
), len
, SCM_ARG2
, s_vector_set_length_x
);
152 scm_wta (SCM_MAKINUM (l
* sz
), (char *) SCM_NALLOC
, s_vector_set_length_x
);
156 scm_must_realloc (SCM_CHARS (vect
),
157 (long) SCM_LENGTH (vect
) * sz
,
159 s_vector_set_length_x
)));
160 if (SCM_VECTORP (vect
))
162 sz
= SCM_LENGTH (vect
);
164 SCM_VELTS (vect
)[--l
] = SCM_UNSPECIFIED
;
166 else if (SCM_STRINGP (vect
))
167 SCM_CHARS (vect
)[l
- 1] = 0;
168 SCM_SETLENGTH (vect
, SCM_INUM (len
), SCM_TYP7 (vect
));
188 SCM_SETCAR (z
, scm_tc_flo
);
198 scm_make_uve (k
, prot
)
204 if (SCM_BOOL_T
== prot
)
206 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
207 type
= scm_tc7_bvect
;
209 else if (SCM_ICHRP (prot
) && (prot
== SCM_MAKICHR ('\0')))
211 i
= sizeof (char) * k
;
212 type
= scm_tc7_byvect
;
214 else if (SCM_ICHRP (prot
))
216 i
= sizeof (char) * k
;
217 type
= scm_tc7_string
;
219 else if (SCM_INUMP (prot
))
221 i
= sizeof (long) * k
;
222 if (SCM_INUM (prot
) > 0)
223 type
= scm_tc7_uvect
;
225 type
= scm_tc7_ivect
;
227 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
) && (1 == SCM_LENGTH (prot
)))
231 s
= SCM_CHARS (prot
)[0];
234 i
= sizeof (short) * k
;
235 type
= scm_tc7_svect
;
240 i
= sizeof (long_long
) * k
;
241 type
= scm_tc7_llvect
;
246 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
, SCM_UNDEFINED
);
251 if (SCM_IMP (prot
) || !SCM_INEXP (prot
))
253 /* Huge non-unif vectors are NOT supported. */
254 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
, SCM_UNDEFINED
); /* no special scm_vector */
257 else if (SCM_SINGP (prot
))
260 i
= sizeof (float) * k
;
261 type
= scm_tc7_fvect
;
264 else if (SCM_CPLXP (prot
))
266 i
= 2 * sizeof (double) * k
;
267 type
= scm_tc7_cvect
;
271 i
= sizeof (double) * k
;
272 type
= scm_tc7_dvect
;
280 m
= scm_must_malloc ((i
? i
: 1L), "vector");
281 SCM_SETCHARS (v
, (char *) m
);
283 SCM_SETLENGTH (v
, (k
< SCM_LENGTH_MAX
? k
: SCM_LENGTH_MAX
), type
);
288 SCM_PROC(s_uniform_vector_length
, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length
);
291 scm_uniform_vector_length (v
)
294 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
299 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_uniform_vector_length
);
313 return SCM_MAKINUM (SCM_LENGTH (v
));
317 SCM_PROC(s_array_p
, "array?", 1, 1, 0, scm_array_p
);
320 scm_array_p (v
, prot
)
326 nprot
= SCM_UNBNDP (prot
);
331 switch (SCM_TYP7 (v
))
343 return nprot
|| SCM_BOOL_T
==prot
? SCM_BOOL_T
: SCM_BOOL_F
;
345 return nprot
|| (SCM_ICHRP(prot
) && (prot
!= SCM_MAKICHR('\0'))) ? SCM_BOOL_T
: SCM_BOOL_F
;
347 return nprot
|| (prot
== SCM_MAKICHR('\0')) ? SCM_BOOL_T
: SCM_BOOL_F
;
349 return nprot
|| (SCM_INUMP(prot
) && SCM_INUM(prot
)>0) ? SCM_BOOL_T
: SCM_BOOL_F
;
351 return nprot
|| (SCM_INUMP(prot
) && SCM_INUM(prot
)<=0) ? SCM_BOOL_T
: SCM_BOOL_F
;
355 && SCM_SYMBOLP (prot
)
356 && (1 == SCM_LENGTH (prot
))
357 && ('s' == SCM_CHARS (prot
)[0])));
362 && SCM_SYMBOLP (prot
)
363 && (1 == SCM_LENGTH (prot
))
364 && ('s' == SCM_CHARS (prot
)[0])));
369 return nprot
|| (SCM_NIMP(prot
) && SCM_SINGP(prot
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
372 return nprot
|| (SCM_NIMP(prot
) && SCM_REALP(prot
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
374 return nprot
|| (SCM_NIMP(prot
) && SCM_CPLXP(prot
)) ? SCM_BOOL_T
: SCM_BOOL_F
;
377 return nprot
|| SCM_NULLP(prot
) ? SCM_BOOL_T
: SCM_BOOL_F
;
384 SCM_PROC(s_array_rank
, "array-rank", 1, 0, 0, scm_array_rank
);
392 switch (SCM_TYP7 (ra
))
408 return SCM_MAKINUM (1L);
411 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
417 SCM_PROC(s_array_dimensions
, "array-dimensions", 1, 0, 0, scm_array_dimensions
);
420 scm_array_dimensions (ra
)
428 switch (SCM_TYP7 (ra
))
445 return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra
)), SCM_EOL
);
447 if (!SCM_ARRAYP (ra
))
449 k
= SCM_ARRAY_NDIM (ra
);
450 s
= SCM_ARRAY_DIMS (ra
);
452 res
= scm_cons (s
[k
].lbnd
? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
), SCM_MAKINUM (s
[k
].ubnd
), SCM_EOL
) :
453 SCM_MAKINUM (1 + (s
[k
].ubnd
))
460 static char s_bad_ind
[] = "Bad scm_array index";
464 scm_aind (ra
, args
, what
)
471 register scm_sizet pos
= SCM_ARRAY_BASE (ra
);
472 register scm_sizet k
= SCM_ARRAY_NDIM (ra
);
473 scm_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
474 if (SCM_INUMP (args
))
476 SCM_ASSERT (1 == k
, scm_makfrom0str (what
), SCM_WNA
, NULL
);
477 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
479 while (k
&& SCM_NIMP (args
))
481 ind
= SCM_CAR (args
);
482 args
= SCM_CDR (args
);
483 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, what
);
485 SCM_ASSERT (j
>= (s
->lbnd
) && j
<= (s
->ubnd
), ind
, SCM_OUTOFRANGE
, what
);
486 pos
+= (j
- s
->lbnd
) * (s
->inc
);
490 SCM_ASSERT (0 == k
&& SCM_NULLP (args
), scm_makfrom0str (what
), SCM_WNA
,
504 SCM_SETCDR (ra
, scm_must_malloc ((long) (sizeof (scm_array
) + ndim
* sizeof (scm_array_dim
)),
506 SCM_SETCAR (ra
, ((long) ndim
<< 17) + scm_tc16_array
);
507 SCM_ARRAY_V (ra
) = scm_nullvect
;
512 static char s_bad_spec
[] = "Bad scm_array dimension";
513 /* Increments will still need to be set. */
517 scm_shap2ra (args
, what
)
523 int ndim
= scm_ilength (args
);
524 SCM_ASSERT (0 <= ndim
, args
, s_bad_spec
, what
);
525 ra
= scm_make_ra (ndim
);
526 SCM_ARRAY_BASE (ra
) = 0;
527 s
= SCM_ARRAY_DIMS (ra
);
528 for (; SCM_NIMP (args
); s
++, args
= SCM_CDR (args
))
530 spec
= SCM_CAR (args
);
534 SCM_ASSERT (SCM_INUMP (spec
) && SCM_INUM (spec
) >= 0, spec
, s_bad_spec
, what
);
536 s
->ubnd
= SCM_INUM (spec
) - 1;
541 SCM_ASSERT (SCM_CONSP (spec
) && SCM_INUMP (SCM_CAR (spec
)), spec
, s_bad_spec
, what
);
542 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
544 SCM_ASSERT (SCM_INUMP (SCM_CAR (sp
)) && SCM_NULLP (SCM_CDR (sp
)),
545 spec
, s_bad_spec
, what
);
546 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
553 SCM_PROC(s_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array
);
556 scm_dimensions_to_uniform_array (dims
, prot
, fill
)
561 scm_sizet k
, vlen
= 1;
565 if (SCM_INUMP (dims
))
566 if (SCM_INUM (dims
) < SCM_LENGTH_MAX
)
569 answer
= scm_make_uve (SCM_INUM (dims
), prot
);
570 if (SCM_NNULLP (fill
))
572 SCM_ASSERT (1 == scm_ilength (fill
),
573 scm_makfrom0str (s_dimensions_to_uniform_array
),
575 scm_array_fill_x (answer
, SCM_CAR (fill
));
577 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
))
578 scm_array_fill_x (answer
, SCM_MAKINUM (0));
580 scm_array_fill_x (answer
, prot
);
584 dims
= scm_cons (dims
, SCM_EOL
);
585 SCM_ASSERT (SCM_NULLP (dims
) || (SCM_NIMP (dims
) && SCM_CONSP (dims
)),
586 dims
, SCM_ARG1
, s_dimensions_to_uniform_array
);
587 ra
= scm_shap2ra (dims
, s_dimensions_to_uniform_array
);
588 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
589 s
= SCM_ARRAY_DIMS (ra
);
590 k
= SCM_ARRAY_NDIM (ra
);
593 s
[k
].inc
= (rlen
> 0 ? rlen
: 0);
594 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
595 vlen
*= (s
[k
].ubnd
- s
[k
].lbnd
+ 1);
597 if (rlen
< SCM_LENGTH_MAX
)
598 SCM_ARRAY_V (ra
) = scm_make_uve ((rlen
> 0 ? rlen
: 0L), prot
);
602 switch (SCM_TYP7 (scm_make_uve (0L, prot
)))
614 bit
= sizeof (float) * SCM_CHAR_BIT
/ sizeof (char);
617 bit
= sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
620 bit
= 2 * sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
623 SCM_ARRAY_BASE (ra
) = (SCM_LONG_BIT
+ bit
- 1) / bit
;
624 rlen
+= SCM_ARRAY_BASE (ra
);
625 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
626 *((long *) SCM_VELTS (SCM_ARRAY_V (ra
))) = rlen
;
628 if (SCM_NNULLP (fill
))
630 SCM_ASSERT (1 == scm_ilength (fill
),
631 scm_makfrom0str (s_dimensions_to_uniform_array
), SCM_WNA
,
633 scm_array_fill_x (ra
, SCM_CAR (fill
));
635 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
))
636 scm_array_fill_x (ra
, SCM_MAKINUM (0));
638 scm_array_fill_x (ra
, prot
);
639 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
640 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
641 return SCM_ARRAY_V (ra
);
647 scm_ra_set_contp (ra
)
650 scm_sizet k
= SCM_ARRAY_NDIM (ra
);
653 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
656 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
658 SCM_SETAND_CAR (ra
, ~SCM_ARRAY_CONTIGUOUS
);
661 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
662 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
665 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
669 SCM_PROC(s_make_shared_array
, "make-shared-array", 2, 0, 1, scm_make_shared_array
);
672 scm_make_shared_array (oldra
, mapfunc
, dims
)
681 long old_min
, new_min
, old_max
, new_max
;
683 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (mapfunc
), mapfunc
, SCM_ARG2
, s_make_shared_array
);
684 SCM_ASSERT (SCM_NIMP (oldra
) && (SCM_BOOL_F
!= scm_array_p (oldra
, SCM_UNDEFINED
)), oldra
, SCM_ARG1
, s_make_shared_array
);
685 ra
= scm_shap2ra (dims
, s_make_shared_array
);
686 if (SCM_ARRAYP (oldra
))
688 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
689 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
690 s
= SCM_ARRAY_DIMS (oldra
);
691 k
= SCM_ARRAY_NDIM (oldra
);
695 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
697 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
702 SCM_ARRAY_V (ra
) = oldra
;
704 old_max
= (long) SCM_LENGTH (oldra
) - 1;
707 s
= SCM_ARRAY_DIMS (ra
);
708 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
710 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
711 if (s
[k
].ubnd
< s
[k
].lbnd
)
713 if (1 == SCM_ARRAY_NDIM (ra
))
714 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
716 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
720 imap
= scm_apply (mapfunc
, scm_list_reverse (inds
), SCM_EOL
);
721 if (SCM_ARRAYP (oldra
))
722 i
= (scm_sizet
) scm_aind (oldra
, imap
, s_make_shared_array
);
725 if (SCM_NINUMP (imap
))
728 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
729 imap
, s_bad_ind
, s_make_shared_array
);
730 imap
= SCM_CAR (imap
);
734 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
736 k
= SCM_ARRAY_NDIM (ra
);
739 if (s
[k
].ubnd
> s
[k
].lbnd
)
741 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
742 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
743 if (SCM_ARRAYP (oldra
))
745 s
[k
].inc
= scm_aind (oldra
, imap
, s_make_shared_array
) - i
;
748 if (SCM_NINUMP (imap
))
751 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
752 imap
, s_bad_ind
, s_make_shared_array
);
753 imap
= SCM_CAR (imap
);
755 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
759 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
761 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
764 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
765 indptr
= SCM_CDR (indptr
);
767 SCM_ASSERT (old_min
<= new_min
&& old_max
>= new_max
, SCM_UNDEFINED
,
768 "mapping out of range", s_make_shared_array
);
769 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
771 if (1 == s
->inc
&& 0 == s
->lbnd
772 && SCM_LENGTH (SCM_ARRAY_V (ra
)) == 1 + s
->ubnd
)
773 return SCM_ARRAY_V (ra
);
774 if (s
->ubnd
< s
->lbnd
)
775 return scm_make_uve (0L, scm_array_prototype (ra
));
777 scm_ra_set_contp (ra
);
782 /* args are RA . DIMS */
783 SCM_PROC(s_transpose_array
, "transpose-array", 0, 0, 1, scm_transpose_array
);
786 scm_transpose_array (args
)
789 SCM ra
, res
, vargs
, *ve
= &vargs
;
790 scm_array_dim
*s
, *r
;
792 SCM_ASSERT (SCM_NNULLP (args
), scm_makfrom0str (s_transpose_array
),
795 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, s_transpose_array
);
796 args
= SCM_CDR (args
);
797 switch (SCM_TYP7 (ra
))
800 badarg
:scm_wta (ra
, (char *) SCM_ARGn
, s_transpose_array
);
813 SCM_ASSERT (SCM_NIMP (args
) && SCM_NULLP (SCM_CDR (args
)),
814 scm_makfrom0str (s_transpose_array
), SCM_WNA
, NULL
);
815 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), SCM_CAR (args
), SCM_ARG2
,
817 SCM_ASSERT (SCM_INUM0
== SCM_CAR (args
), SCM_CAR (args
), SCM_OUTOFRANGE
,
821 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
822 vargs
= scm_vector (args
);
823 SCM_ASSERT (SCM_LENGTH (vargs
) == SCM_ARRAY_NDIM (ra
),
824 scm_makfrom0str (s_transpose_array
), SCM_WNA
, NULL
);
825 ve
= SCM_VELTS (vargs
);
827 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
829 i
= SCM_INUM (ve
[k
]);
830 SCM_ASSERT (SCM_INUMP (ve
[k
]) && i
>= 0 && i
< SCM_ARRAY_NDIM (ra
),
831 ve
[k
], SCM_ARG2
, s_transpose_array
);
836 res
= scm_make_ra (ndim
);
837 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
838 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
841 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
842 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
844 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
846 i
= SCM_INUM (ve
[k
]);
847 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
848 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
849 if (r
->ubnd
< r
->lbnd
)
858 if (r
->ubnd
> s
->ubnd
)
860 if (r
->lbnd
< s
->lbnd
)
862 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
868 SCM_ASSERT (ndim
<= 0, args
, "bad argument scm_list", s_transpose_array
);
869 scm_ra_set_contp (res
);
874 /* args are RA . AXES */
875 SCM_PROC(s_enclose_array
, "enclose-array", 0, 0, 1, scm_enclose_array
);
878 scm_enclose_array (axes
)
881 SCM axv
, ra
, res
, ra_inr
;
882 scm_array_dim vdim
, *s
= &vdim
;
883 int ndim
, j
, k
, ninr
, noutr
;
884 SCM_ASSERT (SCM_NIMP (axes
), scm_makfrom0str (s_enclose_array
), SCM_WNA
,
887 axes
= SCM_CDR (axes
);
888 if (SCM_NULLP (axes
))
890 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
891 ninr
= scm_ilength (axes
);
892 ra_inr
= scm_make_ra (ninr
);
893 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
898 badarg1
:scm_wta (ra
, (char *) SCM_ARG1
, s_enclose_array
);
913 s
->ubnd
= SCM_LENGTH (ra
) - 1;
915 SCM_ARRAY_V (ra_inr
) = ra
;
916 SCM_ARRAY_BASE (ra_inr
) = 0;
920 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
921 s
= SCM_ARRAY_DIMS (ra
);
922 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
923 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
924 ndim
= SCM_ARRAY_NDIM (ra
);
928 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKICHR (0));
929 SCM_ASSERT (0 <= noutr
&& 0 <= ninr
, scm_makfrom0str (s_enclose_array
),
931 res
= scm_make_ra (noutr
);
932 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
933 SCM_ARRAY_V (res
) = ra_inr
;
934 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
936 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes
)), SCM_CAR (axes
), "bad axis", s_enclose_array
);
937 j
= SCM_INUM (SCM_CAR (axes
));
938 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
939 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
940 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
941 SCM_CHARS (axv
)[j
] = 1;
943 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
945 while (SCM_CHARS (axv
)[j
])
947 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
948 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
949 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
951 scm_ra_set_contp (ra_inr
);
952 scm_ra_set_contp (res
);
958 SCM_PROC(s_array_in_bounds_p
, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p
);
961 scm_array_in_bounds_p (args
)
964 SCM v
, ind
= SCM_EOL
;
966 register scm_sizet k
;
969 SCM_ASSERT (SCM_NIMP (args
), scm_makfrom0str (s_array_in_bounds_p
),
972 args
= SCM_CDR (args
);
973 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
977 ind
= SCM_CAR (args
);
978 args
= SCM_CDR (args
);
979 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, s_array_in_bounds_p
);
980 pos
= SCM_INUM (ind
);
987 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_array_in_bounds_p
);
988 wna
: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p
));
990 k
= SCM_ARRAY_NDIM (v
);
991 s
= SCM_ARRAY_DIMS (v
);
992 pos
= SCM_ARRAY_BASE (v
);
995 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
1002 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
1004 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
1007 pos
+= (j
- s
->lbnd
) * (s
->inc
);
1008 if (!(--k
&& SCM_NIMP (args
)))
1010 ind
= SCM_CAR (args
);
1011 args
= SCM_CDR (args
);
1013 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, s_array_in_bounds_p
);
1015 SCM_ASRTGO (0 == k
, wna
);
1016 v
= SCM_ARRAY_V (v
);
1019 case scm_tc7_string
:
1020 case scm_tc7_byvect
:
1028 case scm_tc7_llvect
:
1030 case scm_tc7_vector
:
1031 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
1032 return pos
>= 0 && pos
< SCM_LENGTH (v
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1037 SCM_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
1038 SCM_PROC(s_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref
);
1041 scm_uniform_vector_ref (v
, args
)
1049 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
1052 else if (SCM_ARRAYP (v
))
1054 pos
= scm_aind (v
, args
, s_uniform_vector_ref
);
1055 v
= SCM_ARRAY_V (v
);
1059 if (SCM_NIMP (args
))
1062 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, s_uniform_vector_ref
);
1063 pos
= SCM_INUM (SCM_CAR (args
));
1064 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1068 SCM_ASSERT (SCM_INUMP (args
), args
, SCM_ARG2
, s_uniform_vector_ref
);
1069 pos
= SCM_INUM (args
);
1071 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1077 if (SCM_NULLP (args
))
1080 scm_wta (v
, (char *) SCM_ARG1
, s_uniform_vector_ref
);
1082 outrng
:scm_out_of_range (s_uniform_vector_ref
, SCM_MAKINUM (pos
));
1083 wna
: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref
));
1086 int k
= SCM_ARRAY_NDIM (v
);
1087 SCM res
= scm_make_ra (k
);
1088 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1089 SCM_ARRAY_BASE (res
) = pos
;
1092 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1093 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1094 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1099 if (SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] & (1L << (pos
% SCM_LONG_BIT
)))
1103 case scm_tc7_string
:
1104 return SCM_MAKICHR (SCM_CHARS (v
)[pos
]);
1105 case scm_tc7_byvect
:
1106 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1107 # ifdef SCM_INUMS_ONLY
1110 return SCM_MAKINUM (SCM_VELTS (v
)[pos
]);
1113 return scm_ulong2num(SCM_VELTS(v
)[pos
]);
1115 return scm_long2num(SCM_VELTS(v
)[pos
]);
1119 return SCM_MAKINUM (((short *) SCM_CDR (v
))[pos
]);
1121 case scm_tc7_llvect
:
1122 return scm_long_long2num (((long_long
*) SCM_CDR (v
))[pos
]);
1128 return scm_makflo (((float *) SCM_CDR (v
))[pos
]);
1131 return scm_makdbl (((double *) SCM_CDR (v
))[pos
], 0.0);
1133 return scm_makdbl (((double *) SCM_CDR (v
))[2 * pos
],
1134 ((double *) SCM_CDR (v
))[2 * pos
+ 1]);
1136 case scm_tc7_vector
:
1137 return SCM_VELTS (v
)[pos
];
1141 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1142 tries to recycle conses. (Make *sure* you want them recycled.) */
1145 scm_cvref (v
, pos
, last
)
1154 scm_wta (v
, (char *) SCM_ARG1
, "PROGRAMMING ERROR: scm_cvref");
1156 if (SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] & (1L << (pos
% SCM_LONG_BIT
)))
1160 case scm_tc7_string
:
1161 return SCM_MAKICHR (SCM_CHARS (v
)[pos
]);
1162 case scm_tc7_byvect
:
1163 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1164 # ifdef SCM_INUMS_ONLY
1167 return SCM_MAKINUM (SCM_VELTS (v
)[pos
]);
1170 return scm_ulong2num(SCM_VELTS(v
)[pos
]);
1172 return scm_long2num(SCM_VELTS(v
)[pos
]);
1175 return SCM_MAKINUM (((short *) SCM_CDR (v
))[pos
]);
1177 case scm_tc7_llvect
:
1178 return scm_long_long2num (((long_long
*) SCM_CDR (v
))[pos
]);
1183 if (SCM_NIMP (last
) && (last
!= scm_flo0
) && (scm_tc_flo
== SCM_CAR (last
)))
1185 SCM_FLO (last
) = ((float *) SCM_CDR (v
))[pos
];
1188 return scm_makflo (((float *) SCM_CDR (v
))[pos
]);
1192 if (SCM_NIMP (last
) && scm_tc_dblr
== SCM_CAR (last
))
1194 if (SCM_NIMP (last
) && (last
!= scm_flo0
) && (scm_tc_dblr
== SCM_CAR (last
)))
1197 SCM_REAL (last
) = ((double *) SCM_CDR (v
))[pos
];
1200 return scm_makdbl (((double *) SCM_CDR (v
))[pos
], 0.0);
1202 if (SCM_NIMP (last
) && scm_tc_dblc
== SCM_CAR (last
))
1204 SCM_REAL (last
) = ((double *) SCM_CDR (v
))[2 * pos
];
1205 SCM_IMAG (last
) = ((double *) SCM_CDR (v
))[2 * pos
+ 1];
1208 return scm_makdbl (((double *) SCM_CDR (v
))[2 * pos
],
1209 ((double *) SCM_CDR (v
))[2 * pos
+ 1]);
1211 case scm_tc7_vector
:
1212 return SCM_VELTS (v
)[pos
];
1214 { /* enclosed scm_array */
1215 int k
= SCM_ARRAY_NDIM (v
);
1216 SCM res
= scm_make_ra (k
);
1217 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1218 SCM_ARRAY_BASE (res
) = pos
;
1221 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1222 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1223 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1230 SCM_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1231 SCM_PROC(s_array_set_x
, "array-set!", 2, 0, 1, scm_array_set_x
);
1234 scm_array_set_x (v
, obj
, args
)
1240 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1243 pos
= scm_aind (v
, args
, s_array_set_x
);
1244 v
= SCM_ARRAY_V (v
);
1248 if (SCM_NIMP (args
))
1250 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, s_array_set_x
);
1251 pos
= SCM_INUM (SCM_CAR (args
));
1252 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1256 SCM_ASSERT (SCM_INUMP (args
), args
, SCM_ARG2
, s_array_set_x
);
1257 pos
= SCM_INUM (args
);
1259 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1261 switch (SCM_TYP7 (v
))
1264 scm_wta (v
, (char *) SCM_ARG1
, s_array_set_x
);
1266 outrng
:scm_out_of_range (s_array_set_x
, SCM_MAKINUM (pos
));
1267 wna
: scm_wrong_num_args (scm_makfrom0str (s_array_set_x
));
1268 case scm_tc7_smob
: /* enclosed */
1271 if (SCM_BOOL_F
== obj
)
1272 SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] &= ~(1L << (pos
% SCM_LONG_BIT
));
1273 else if (SCM_BOOL_T
== obj
)
1274 SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] |= (1L << (pos
% SCM_LONG_BIT
));
1276 badarg3
:scm_wta (obj
, (char *) SCM_ARG3
, s_array_set_x
);
1278 case scm_tc7_string
:
1279 SCM_ASRTGO (SCM_ICHRP (obj
), badarg3
);
1280 SCM_CHARS (v
)[pos
] = SCM_ICHR (obj
);
1282 case scm_tc7_byvect
:
1283 if (SCM_ICHRP (obj
))
1284 obj
= SCM_MAKINUM (SCM_ICHR (obj
));
1285 SCM_ASRTGO (SCM_INUMP (obj
), badarg3
);
1286 ((char *)SCM_CHARS (v
))[pos
] = SCM_INUM (obj
);
1288 # ifdef SCM_INUMS_ONLY
1290 SCM_ASRTGO (SCM_INUM (obj
) >= 0, badarg3
);
1292 SCM_ASRTGO(SCM_INUMP(obj
), badarg3
); SCM_VELTS(v
)[pos
] = SCM_INUM(obj
); break;
1295 SCM_VELTS(v
)[pos
] = scm_num2ulong(obj
, (char *)SCM_ARG3
, s_array_set_x
); break;
1297 SCM_VELTS(v
)[pos
] = num2long(obj
, (char *)SCM_ARG3
, s_array_set_x
); break;
1302 SCM_ASRTGO (SCM_INUMP (obj
), badarg3
);
1303 ((short *) SCM_CDR (v
))[pos
] = SCM_INUM (obj
);
1306 case scm_tc7_llvect
:
1307 ((long_long
*) SCM_CDR (v
))[pos
] = scm_num2long_long (obj
, (char *)SCM_ARG3
, s_array_set_x
);
1315 SCM_ASRTGO (SCM_NIMP (obj
) && SCM_REALP (obj
), badarg3
);
1316 ((float *) SCM_CDR (v
))[pos
] = SCM_REALPART (obj
);
1320 SCM_ASRTGO (SCM_NIMP (obj
) && SCM_REALP (obj
), badarg3
);
1321 ((double *) SCM_CDR (v
))[pos
] = SCM_REALPART (obj
);
1324 SCM_ASRTGO (SCM_NIMP (obj
) && SCM_INEXP (obj
), badarg3
);
1325 ((double *) SCM_CDR (v
))[2 * pos
] = SCM_REALPART (obj
);
1326 ((double *) SCM_CDR (v
))[2 * pos
+ 1] = SCM_CPLXP (obj
) ? SCM_IMAG (obj
) : 0.0;
1329 case scm_tc7_vector
:
1330 SCM_VELTS (v
)[pos
] = obj
;
1333 return SCM_UNSPECIFIED
;
1336 SCM_PROC(s_array_contents
, "array-contents", 1, 1, 0, scm_array_contents
);
1339 scm_array_contents (ra
, strict
)
1351 case scm_tc7_vector
:
1352 case scm_tc7_string
:
1354 case scm_tc7_byvect
:
1362 case scm_tc7_llvect
:
1367 scm_sizet k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1368 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1370 for (k
= 0; k
< ndim
; k
++)
1371 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1372 if (!SCM_UNBNDP (strict
))
1375 (ra
) return SCM_BOOL_F
;
1376 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1378 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1380 if (len
!= SCM_LENGTH (SCM_ARRAY_V (ra
)) ||
1381 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1386 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
))) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1387 return SCM_ARRAY_V (ra
);
1388 sra
= scm_make_ra (1);
1389 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1390 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1391 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1392 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1393 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1401 scm_ra2contig (ra
, copy
)
1407 scm_sizet k
, len
= 1;
1408 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1409 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1410 k
= SCM_ARRAY_NDIM (ra
);
1411 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1413 if (scm_tc7_bvect
!= SCM_TYP7 (ra
))
1415 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
)) &&
1416 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1417 0 == len
% SCM_LONG_BIT
))
1420 ret
= scm_make_ra (k
);
1421 SCM_ARRAY_BASE (ret
) = 0;
1424 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1425 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1426 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1427 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1429 SCM_ARRAY_V (ret
) = scm_make_uve ((inc
- 1), scm_array_prototype (ra
));
1431 scm_array_copy_x (ra
, ret
);
1437 SCM_PROC(s_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x
);
1440 scm_uniform_array_read_x (ra
, port_or_fd
, start
, end
)
1446 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1452 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1453 if (SCM_UNBNDP (port_or_fd
))
1454 port_or_fd
= scm_cur_inp
;
1456 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1457 || (SCM_NIMP (port_or_fd
) && SCM_OPINFPORTP (port_or_fd
)),
1458 port_or_fd
, SCM_ARG2
, s_uniform_array_read_x
);
1459 vlen
= SCM_LENGTH (v
);
1465 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_uniform_array_read_x
);
1467 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1468 cra
= scm_ra2contig (ra
, 0);
1469 cstart
+= SCM_ARRAY_BASE (cra
);
1470 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1471 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1472 v
= SCM_ARRAY_V (cra
);
1474 case scm_tc7_string
:
1475 case scm_tc7_byvect
:
1479 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1480 cstart
/= SCM_LONG_BIT
;
1486 sz
= sizeof (short);
1489 case scm_tc7_llvect
:
1490 sz
= sizeof (long_long
);
1496 sz
= sizeof (float);
1500 sz
= sizeof (double);
1503 sz
= 2 * sizeof (double);
1509 if (!SCM_UNBNDP (start
))
1512 scm_num2long (start
, (char *) SCM_ARG3
, s_uniform_array_read_x
);
1514 if (offset
< 0 || offset
>= cend
)
1515 scm_out_of_range (s_uniform_array_read_x
, start
);
1517 if (!SCM_UNBNDP (end
))
1520 scm_num2long (end
, (char *) SCM_ARG4
, s_uniform_array_read_x
);
1522 if (tend
<= offset
|| tend
> cend
)
1523 scm_out_of_range (s_uniform_array_read_x
, end
);
1528 if (SCM_NIMP (port_or_fd
))
1530 /* if we have stored a character from the port in our own buffer,
1531 push it back onto the stream. */
1532 /* An ungetc before an fread will not work on some systems if
1533 setbuf(0). do #define NOSETBUF in scmfig.h to fix this. */
1534 if (SCM_CRDYP (port_or_fd
))
1536 ungetc (SCM_CGETUN (port_or_fd
), (FILE *)SCM_STREAM (port_or_fd
));
1537 SCM_CLRDY (port_or_fd
); /* Clear ungetted char */
1539 SCM_SYSCALL (ans
= fread (SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1540 (scm_sizet
) sz
, (scm_sizet
) (cend
- offset
),
1541 (FILE *)SCM_STREAM (port_or_fd
)));
1543 else /* file descriptor. */
1545 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1546 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1547 (scm_sizet
) (sz
* (cend
- offset
))));
1549 scm_syserror (s_uniform_array_read_x
);
1551 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1552 ans
*= SCM_LONG_BIT
;
1554 if (v
!= ra
&& cra
!= ra
)
1555 scm_array_copy_x (cra
, ra
);
1557 return SCM_MAKINUM (ans
);
1560 SCM_PROC(s_uniform_array_write
, "uniform-array-write", 1, 3, 0, scm_uniform_array_write
);
1563 scm_uniform_array_write (v
, port_or_fd
, start
, end
)
1574 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1575 if (SCM_UNBNDP (port_or_fd
))
1576 port_or_fd
= scm_cur_outp
;
1578 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1579 || (SCM_NIMP (port_or_fd
) && SCM_OPOUTFPORTP (port_or_fd
)),
1580 port_or_fd
, SCM_ARG2
, s_uniform_array_write
);
1581 vlen
= SCM_LENGTH (v
);
1587 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_uniform_array_write
);
1589 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1590 v
= scm_ra2contig (v
, 1);
1591 cstart
= SCM_ARRAY_BASE (v
);
1592 vlen
= SCM_ARRAY_DIMS (v
)->inc
1593 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1594 v
= SCM_ARRAY_V (v
);
1596 case scm_tc7_string
:
1597 case scm_tc7_byvect
:
1601 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1602 cstart
/= SCM_LONG_BIT
;
1608 sz
= sizeof (short);
1611 case scm_tc7_llvect
:
1612 sz
= sizeof (long_long
);
1618 sz
= sizeof (float);
1622 sz
= sizeof (double);
1625 sz
= 2 * sizeof (double);
1631 if (!SCM_UNBNDP (start
))
1634 scm_num2long (start
, (char *) SCM_ARG3
, s_uniform_array_write
);
1636 if (offset
< 0 || offset
>= cend
)
1637 scm_out_of_range (s_uniform_array_write
, start
);
1639 if (!SCM_UNBNDP (end
))
1642 scm_num2long (end
, (char *) SCM_ARG4
, s_uniform_array_write
);
1644 if (tend
<= offset
|| tend
> cend
)
1645 scm_out_of_range (s_uniform_array_write
, end
);
1650 if (SCM_NIMP (port_or_fd
))
1652 SCM_SYSCALL (ans
= fwrite (SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1653 (scm_sizet
) sz
, (scm_sizet
) (cend
- offset
),
1654 (FILE *)SCM_STREAM (port_or_fd
)));
1656 else /* file descriptor. */
1658 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1659 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1660 (scm_sizet
) (sz
* (cend
- offset
))));
1662 scm_syserror (s_uniform_array_write
);
1664 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1665 ans
*= SCM_LONG_BIT
;
1667 return SCM_MAKINUM (ans
);
1671 static char cnt_tab
[16] =
1672 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1674 SCM_PROC(s_bit_count
, "bit-count", 2, 0, 0, scm_bit_count
);
1677 scm_bit_count (item
, seq
)
1682 register unsigned long cnt
= 0, w
;
1683 SCM_ASSERT (SCM_NIMP (seq
), seq
, SCM_ARG2
, s_bit_count
);
1688 scm_wta (seq
, (char *) SCM_ARG2
, s_bit_count
);
1690 if (0 == SCM_LENGTH (seq
))
1692 i
= (SCM_LENGTH (seq
) - 1) / SCM_LONG_BIT
;
1693 w
= SCM_VELTS (seq
)[i
];
1694 if (SCM_FALSEP (item
))
1696 w
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (seq
) - 1) % SCM_LONG_BIT
);
1700 cnt
+= cnt_tab
[w
& 0x0f];
1702 return SCM_MAKINUM (cnt
);
1703 w
= SCM_VELTS (seq
)[i
];
1704 if (SCM_FALSEP (item
))
1711 SCM_PROC(s_bit_position
, "bit-position", 3, 0, 0, scm_bit_position
);
1714 scm_bit_position (item
, v
, k
)
1719 long i
, lenw
, xbits
, pos
= SCM_INUM (k
);
1720 register unsigned long w
;
1721 SCM_ASSERT (SCM_NIMP (v
), v
, SCM_ARG2
, s_bit_position
);
1722 SCM_ASSERT (SCM_INUMP (k
), k
, SCM_ARG3
, s_bit_position
);
1723 SCM_ASSERT ((pos
<= SCM_LENGTH (v
)) && (pos
>= 0),
1724 k
, SCM_OUTOFRANGE
, s_bit_position
);
1725 if (pos
== SCM_LENGTH (v
))
1731 scm_wta (v
, (char *) SCM_ARG2
, s_bit_position
);
1733 if (0 == SCM_LENGTH (v
))
1734 return SCM_MAKINUM (-1L);
1735 lenw
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1736 i
= pos
/ SCM_LONG_BIT
;
1737 w
= SCM_VELTS (v
)[i
];
1738 if (SCM_FALSEP (item
))
1740 xbits
= (pos
% SCM_LONG_BIT
);
1742 w
= ((w
>> xbits
) << xbits
);
1743 xbits
= SCM_LONG_BIT
- 1 - (SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1746 if (w
&& (i
== lenw
))
1747 w
= ((w
<< xbits
) >> xbits
);
1753 return SCM_MAKINUM (pos
);
1758 return SCM_MAKINUM (pos
+ 1);
1761 return SCM_MAKINUM (pos
+ 2);
1763 return SCM_MAKINUM (pos
+ 3);
1770 pos
+= SCM_LONG_BIT
;
1771 w
= SCM_VELTS (v
)[i
];
1772 if (SCM_FALSEP (item
))
1780 SCM_PROC(s_bit_set_star_x
, "bit-set*!", 3, 0, 0, scm_bit_set_star_x
);
1783 scm_bit_set_star_x (v
, kv
, obj
)
1788 register long i
, k
, vlen
;
1789 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1790 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1795 badarg2
:scm_wta (kv
, (char *) SCM_ARG2
, s_bit_set_star_x
);
1801 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_bit_set_star_x
);
1803 vlen
= SCM_LENGTH (v
);
1804 if (SCM_BOOL_F
== obj
)
1805 for (i
= SCM_LENGTH (kv
); i
;)
1807 k
= SCM_VELTS (kv
)[--i
];
1808 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, s_bit_set_star_x
);
1809 SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] &= ~(1L << (k
% SCM_LONG_BIT
));
1811 else if (SCM_BOOL_T
== obj
)
1812 for (i
= SCM_LENGTH (kv
); i
;)
1814 k
= SCM_VELTS (kv
)[--i
];
1815 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, s_bit_set_star_x
);
1816 SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] |= (1L << (k
% SCM_LONG_BIT
));
1819 badarg3
:scm_wta (obj
, (char *) SCM_ARG3
, s_bit_set_star_x
);
1823 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1824 if (SCM_BOOL_F
== obj
)
1825 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1826 SCM_VELTS (v
)[k
] &= ~(SCM_VELTS (kv
)[k
]);
1827 else if (SCM_BOOL_T
== obj
)
1828 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1829 SCM_VELTS (v
)[k
] |= SCM_VELTS (kv
)[k
];
1834 return SCM_UNSPECIFIED
;
1838 SCM_PROC(s_bit_count_star
, "bit-count*", 3, 0, 0, scm_bit_count_star
);
1841 scm_bit_count_star (v
, kv
, obj
)
1846 register long i
, vlen
, count
= 0;
1847 register unsigned long k
;
1848 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1849 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1854 badarg2
:scm_wta (kv
, (char *) SCM_ARG2
, s_bit_count_star
);
1860 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_bit_count_star
);
1862 vlen
= SCM_LENGTH (v
);
1863 if (SCM_BOOL_F
== obj
)
1864 for (i
= SCM_LENGTH (kv
); i
;)
1866 k
= SCM_VELTS (kv
)[--i
];
1867 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, s_bit_count_star
);
1868 if (!(SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] & (1L << (k
% SCM_LONG_BIT
))))
1871 else if (SCM_BOOL_T
== obj
)
1872 for (i
= SCM_LENGTH (kv
); i
;)
1874 k
= SCM_VELTS (kv
)[--i
];
1875 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, s_bit_count_star
);
1876 if (SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] & (1L << (k
% SCM_LONG_BIT
)))
1880 badarg3
:scm_wta (obj
, (char *) SCM_ARG3
, s_bit_count_star
);
1884 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1885 if (0 == SCM_LENGTH (v
))
1887 SCM_ASRTGO (SCM_BOOL_T
== obj
|| SCM_BOOL_F
== obj
, badarg3
);
1888 obj
= (SCM_BOOL_T
== obj
);
1889 i
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1890 k
= SCM_VELTS (kv
)[i
] & (obj
? SCM_VELTS (v
)[i
] : ~SCM_VELTS (v
)[i
]);
1891 k
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1895 count
+= cnt_tab
[k
& 0x0f];
1897 return SCM_MAKINUM (count
);
1898 k
= SCM_VELTS (kv
)[i
] & (obj
? SCM_VELTS (v
)[i
] : ~SCM_VELTS (v
)[i
]);
1901 return SCM_MAKINUM (count
);
1905 SCM_PROC(s_bit_invert_x
, "bit-invert!", 1, 0, 0, scm_bit_invert_x
);
1908 scm_bit_invert_x (v
)
1912 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1918 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1919 SCM_VELTS (v
)[k
] = ~SCM_VELTS (v
)[k
];
1922 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_bit_invert_x
);
1924 return SCM_UNSPECIFIED
;
1928 SCM_PROC(s_string_upcase_x
, "string-upcase!", 1, 0, 0, scm_string_upcase_x
);
1931 scm_string_upcase_x (v
)
1935 register unsigned char *cs
;
1936 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1941 case scm_tc7_string
:
1942 cs
= SCM_UCHARS (v
);
1944 cs
[k
] = scm_upcase(cs
[k
]);
1947 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_upcase_x
);
1952 SCM_PROC(s_string_downcase_x
, "string-downcase!", 1, 0, 0, scm_string_downcase_x
);
1955 scm_string_downcase_x (v
)
1959 register unsigned char *cs
;
1960 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1965 case scm_tc7_string
:
1966 cs
= SCM_UCHARS (v
);
1968 cs
[k
] = scm_downcase(cs
[k
]);
1971 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_string_downcase_x
);
1979 scm_istr2bve (str
, len
)
1983 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
1984 long *data
= (long *) SCM_VELTS (v
);
1985 register unsigned long mask
;
1988 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
1991 j
= len
- k
* SCM_LONG_BIT
;
1992 if (j
> SCM_LONG_BIT
)
1994 for (mask
= 1L; j
--; mask
<<= 1)
2011 static SCM ra2l
SCM_P ((SCM ra
, scm_sizet base
, scm_sizet k
));
2019 register SCM res
= SCM_EOL
;
2020 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2021 register scm_sizet i
;
2022 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
2024 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
2025 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2030 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
2038 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
2045 SCM_PROC(s_array_to_list
, "array->list", 1, 0, 0, scm_array_to_list
);
2048 scm_array_to_list (v
)
2053 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
2058 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, s_array_to_list
);
2060 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
2061 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
2062 case scm_tc7_vector
:
2063 return scm_vector_to_list (v
);
2064 case scm_tc7_string
:
2065 return scm_string_to_list (v
);
2068 long *data
= (long *) SCM_VELTS (v
);
2069 register unsigned long mask
;
2070 for (k
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
2071 for (mask
= 1L << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
2072 res
= scm_cons (((long *) data
)[k
] & mask
? SCM_BOOL_T
: SCM_BOOL_F
, res
);
2073 for (mask
= 1L << ((SCM_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
2074 res
= scm_cons (((long *) data
)[k
] & mask
? SCM_BOOL_T
: SCM_BOOL_F
, res
);
2077 # ifdef SCM_INUMS_ONLY
2081 long *data
= (long *) SCM_VELTS (v
);
2082 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2083 res
= scm_cons (SCM_MAKINUM (data
[k
]), res
);
2087 case scm_tc7_uvect
: {
2088 long *data
= (long *)SCM_VELTS(v
);
2089 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2090 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
2093 case scm_tc7_ivect
: {
2094 long *data
= (long *)SCM_VELTS(v
);
2095 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2096 res
= scm_cons(scm_long2num(data
[k
]), res
);
2100 case scm_tc7_svect
: {
2102 data
= (short *)SCM_VELTS(v
);
2103 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2104 res
= scm_cons(SCM_MAKINUM (data
[k
]), res
);
2108 case scm_tc7_llvect
: {
2110 data
= (long_long
*)SCM_VELTS(v
);
2111 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2112 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2122 float *data
= (float *) SCM_VELTS (v
);
2123 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2124 res
= scm_cons (scm_makflo (data
[k
]), res
);
2127 #endif /*SCM_SINGLES*/
2130 double *data
= (double *) SCM_VELTS (v
);
2131 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2132 res
= scm_cons (scm_makdbl (data
[k
], 0.0), res
);
2137 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2138 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2139 res
= scm_cons (scm_makdbl (data
[k
][0], data
[k
][1]), res
);
2142 #endif /*SCM_FLOATS*/
2147 static char s_bad_ralst
[] = "Bad scm_array contents scm_list";
2149 static int l2ra
SCM_P ((SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
));
2151 SCM_PROC(s_list_to_uniform_array
, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array
);
2154 scm_list_to_uniform_array (ndim
, prot
, lst
)
2164 SCM_ASSERT (SCM_INUMP (ndim
), ndim
, SCM_ARG1
, s_list_to_uniform_array
);
2165 k
= SCM_INUM (ndim
);
2168 n
= scm_ilength (row
);
2169 SCM_ASSERT (n
>= 0, lst
, SCM_ARG2
, s_list_to_uniform_array
);
2170 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2172 row
= SCM_CAR (row
);
2174 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
, SCM_EOL
);
2175 if (SCM_NULLP (shp
))
2178 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2179 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2182 if (!SCM_ARRAYP (ra
))
2184 for (k
= 0; k
< SCM_LENGTH (ra
); k
++, lst
= SCM_CDR (lst
))
2185 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2188 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2191 badlst
:scm_wta (lst
, s_bad_ralst
, s_list_to_uniform_array
);
2196 l2ra (lst
, ra
, base
, k
)
2202 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2203 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2206 return (SCM_EOL
== lst
);
2207 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2211 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2213 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2215 lst
= SCM_CDR (lst
);
2217 if (SCM_NNULLP (lst
))
2224 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2226 ok
= ok
&& scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2228 lst
= SCM_CDR (lst
);
2230 if (SCM_NNULLP (lst
))
2237 static void rapr1
SCM_P ((SCM ra
, scm_sizet j
, scm_sizet k
, SCM port
, scm_print_state
*pstate
));
2240 rapr1 (ra
, j
, k
, port
, pstate
)
2245 scm_print_state
*pstate
;
2248 long n
= SCM_LENGTH (ra
);
2257 SCM_ARRAY_BASE (ra
) = j
;
2259 scm_iprin1 (ra
, port
, pstate
);
2260 for (j
+= inc
; n
-- > 0; j
+= inc
)
2262 scm_gen_putc (' ', port
);
2263 SCM_ARRAY_BASE (ra
) = j
;
2264 scm_iprin1 (ra
, port
, pstate
);
2268 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2271 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2272 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2274 scm_gen_putc ('(', port
);
2275 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2276 scm_gen_puts (scm_regular_string
, ") ", port
);
2279 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2280 { /* could be zero size. */
2281 scm_gen_putc ('(', port
);
2282 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2283 scm_gen_putc (')', port
);
2289 { /* Could be zero-dimensional */
2290 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2291 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2295 ra
= SCM_ARRAY_V (ra
);
2299 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2300 for (j
+= inc
; n
-- > 0; j
+= inc
)
2302 scm_gen_putc (' ', port
);
2303 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2306 case scm_tc7_string
:
2308 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra
)[j
]), port
, pstate
);
2309 if (SCM_WRITINGP (pstate
))
2310 for (j
+= inc
; n
-- > 0; j
+= inc
)
2312 scm_gen_putc (' ', port
);
2313 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra
)[j
]), port
, pstate
);
2316 for (j
+= inc
; n
-- > 0; j
+= inc
)
2317 scm_gen_putc (SCM_CHARS (ra
)[j
], port
);
2319 case scm_tc7_byvect
:
2321 scm_intprint (((char *)SCM_CDR (ra
))[j
], 10, port
);
2322 for (j
+= inc
; n
-- > 0; j
+= inc
)
2324 scm_gen_putc (' ', port
);
2325 scm_intprint (((char *)SCM_CDR (ra
))[j
], 10, port
);
2332 scm_intprint (SCM_VELTS (ra
)[j
], 10, port
);
2333 for (j
+= inc
; n
-- > 0; j
+= inc
)
2335 scm_gen_putc (' ', port
);
2336 scm_intprint (SCM_VELTS (ra
)[j
], 10, port
);
2342 scm_intprint (((short *)SCM_CDR (ra
))[j
], 10, port
);
2343 for (j
+= inc
; n
-- > 0; j
+= inc
)
2345 scm_gen_putc (' ', port
);
2346 scm_intprint (((short *)SCM_CDR (ra
))[j
], 10, port
);
2355 SCM z
= scm_makflo (1.0);
2356 SCM_FLO (z
) = ((float *) SCM_VELTS (ra
))[j
];
2357 scm_floprint (z
, port
, pstate
);
2358 for (j
+= inc
; n
-- > 0; j
+= inc
)
2360 scm_gen_putc (' ', port
);
2361 SCM_FLO (z
) = ((float *) SCM_VELTS (ra
))[j
];
2362 scm_floprint (z
, port
, pstate
);
2366 #endif /*SCM_SINGLES*/
2370 SCM z
= scm_makdbl (1.0 / 3.0, 0.0);
2371 SCM_REAL (z
) = ((double *) SCM_VELTS (ra
))[j
];
2372 scm_floprint (z
, port
, pstate
);
2373 for (j
+= inc
; n
-- > 0; j
+= inc
)
2375 scm_gen_putc (' ', port
);
2376 SCM_REAL (z
) = ((double *) SCM_VELTS (ra
))[j
];
2377 scm_floprint (z
, port
, pstate
);
2384 SCM cz
= scm_makdbl (0.0, 1.0), z
= scm_makdbl (1.0 / 3.0, 0.0);
2385 SCM_REAL (z
) = SCM_REAL (cz
) = (((double *) SCM_VELTS (ra
))[2 * j
]);
2386 SCM_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2387 scm_floprint ((0.0 == SCM_IMAG (cz
) ? z
: cz
), port
, pstate
);
2388 for (j
+= inc
; n
-- > 0; j
+= inc
)
2390 scm_gen_putc (' ', port
);
2391 SCM_REAL (z
) = SCM_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2392 SCM_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2393 scm_floprint ((0.0 == SCM_IMAG (cz
) ? z
: cz
), port
, pstate
);
2397 #endif /*SCM_FLOATS*/
2404 scm_raprin1 (exp
, port
, pstate
)
2407 scm_print_state
*pstate
;
2411 scm_gen_putc ('#', port
);
2418 long ndim
= SCM_ARRAY_NDIM (v
);
2419 base
= SCM_ARRAY_BASE (v
);
2420 v
= SCM_ARRAY_V (v
);
2424 scm_gen_puts (scm_regular_string
, "<enclosed-array ", port
);
2425 rapr1 (exp
, base
, 0, port
, pstate
);
2426 scm_gen_putc ('>', port
);
2431 scm_intprint (ndim
, 10, port
);
2437 { /* a uve, not an scm_array */
2438 register long i
, j
, w
;
2439 scm_gen_putc ('*', port
);
2440 for (i
= 0; i
< (SCM_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2442 w
= SCM_VELTS (exp
)[i
];
2443 for (j
= SCM_LONG_BIT
; j
; j
--)
2445 scm_gen_putc (w
& 1 ? '1' : '0', port
);
2449 j
= SCM_LENGTH (exp
) % SCM_LONG_BIT
;
2452 w
= SCM_VELTS (exp
)[SCM_LENGTH (exp
) / SCM_LONG_BIT
];
2455 scm_gen_putc (w
& 1 ? '1' : '0', port
);
2462 scm_gen_putc ('b', port
);
2464 case scm_tc7_string
:
2465 scm_gen_putc ('a', port
);
2467 case scm_tc7_byvect
:
2468 scm_gen_puts (scm_regular_string
, "bytes", port
);
2471 scm_gen_putc ('u', port
);
2474 scm_gen_putc ('e', port
);
2477 scm_gen_puts (scm_regular_string
, "short", port
);
2480 case scm_tc7_llvect
:
2481 scm_gen_puts (scm_regular_string
, "long_long", port
);
2487 scm_gen_putc ('s', port
);
2489 #endif /*SCM_SINGLES*/
2491 scm_gen_putc ('i', port
);
2494 scm_gen_putc ('c', port
);
2496 #endif /*SCM_FLOATS*/
2498 scm_gen_putc ('(', port
);
2499 rapr1 (exp
, base
, 0, port
, pstate
);
2500 scm_gen_putc (')', port
);
2504 SCM_PROC(s_array_prototype
, "array-prototype", 1, 0, 0, scm_array_prototype
);
2507 scm_array_prototype (ra
)
2511 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2517 badarg
:scm_wta (ra
, (char *) SCM_ARG1
, s_array_prototype
);
2519 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2521 return SCM_UNSPECIFIED
;
2522 ra
= SCM_ARRAY_V (ra
);
2524 case scm_tc7_vector
:
2528 case scm_tc7_string
:
2529 return SCM_MAKICHR ('a');
2530 case scm_tc7_byvect
:
2531 return SCM_MAKICHR ('\0');
2533 return SCM_MAKINUM (1L);
2535 return SCM_MAKINUM (-1L);
2537 return SCM_CDR (scm_intern ("s", 1));
2539 case scm_tc7_llvect
:
2540 return SCM_CDR (scm_intern ("l", 1));
2545 return scm_makflo (1.0);
2548 return scm_makdbl (1.0 / 3.0, 0.0);
2550 return scm_makdbl (0.0, 1.0);
2556 static SCM markra
SCM_P ((SCM ptr
));
2563 (ptr
) return SCM_BOOL_F
;
2564 SCM_SETGC8MARK (ptr
);
2565 return SCM_ARRAY_V (ptr
);
2569 static scm_sizet freera
SCM_P ((SCM ptr
));
2575 scm_must_free (SCM_CHARS (ptr
));
2576 return sizeof (scm_array
) + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_array_dim
);
2579 static scm_smobfuns rasmob
=
2580 {markra
, freera
, scm_raprin1
, scm_array_equal_p
};
2583 /* This must be done after scm_init_scl() */
2589 scm_tc16_array
= scm_newsmob (&rasmob
);
2590 scm_add_feature ("array");
2597 scm_raprin1 (exp
, port
, pstate
)
2600 scm_print_state
*pstate
;
2607 scm_istr2bve (str
, len
)
2617 scm_make_subr (s_resizuve
, scm_tc7_subr_2
, scm_vector_set_length_x
);