1 /* Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
56 #include "scm_validate.h"
65 /* The set of uniform scm_vector types is:
67 * unsigned char string
74 * complex double cvect
81 /* return the size of an element in a uniform array or 0 if type not
84 scm_uniform_element_size (SCM obj
)
88 switch (SCM_TYP7 (obj
))
93 result
= sizeof (long);
97 result
= sizeof (char);
101 result
= sizeof (short);
104 #ifdef HAVE_LONG_LONGS
106 result
= sizeof (long_long
);
113 result
= sizeof (float);
118 result
= sizeof (double);
122 result
= 2 * sizeof (double);
145 SCM_SETCAR (z
, scm_tc_flo
);
155 scm_make_uve (long k
, SCM prot
)
159 if (SCM_BOOL_T
== prot
)
161 i
= sizeof (long) * ((k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
);
162 type
= scm_tc7_bvect
;
164 else if (SCM_ICHRP (prot
) && (prot
== SCM_MAKICHR ('\0')))
166 i
= sizeof (char) * k
;
167 type
= scm_tc7_byvect
;
169 else if (SCM_ICHRP (prot
))
171 i
= sizeof (char) * k
;
172 type
= scm_tc7_string
;
174 else if (SCM_INUMP (prot
))
176 i
= sizeof (long) * k
;
177 if (SCM_INUM (prot
) > 0)
178 type
= scm_tc7_uvect
;
180 type
= scm_tc7_ivect
;
182 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
) && (1 == SCM_LENGTH (prot
)))
186 s
= SCM_CHARS (prot
)[0];
189 i
= sizeof (short) * k
;
190 type
= scm_tc7_svect
;
192 #ifdef HAVE_LONG_LONGS
195 i
= sizeof (long_long
) * k
;
196 type
= scm_tc7_llvect
;
201 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
206 if (SCM_IMP (prot
) || !SCM_INEXP (prot
))
208 /* Huge non-unif vectors are NOT supported. */
209 /* no special scm_vector */
210 return scm_make_vector (SCM_MAKINUM (k
), SCM_UNDEFINED
);
213 else if (SCM_SINGP (prot
))
216 i
= sizeof (float) * k
;
217 type
= scm_tc7_fvect
;
220 else if (SCM_CPLXP (prot
))
222 i
= 2 * sizeof (double) * k
;
223 type
= scm_tc7_cvect
;
227 i
= sizeof (double) * k
;
228 type
= scm_tc7_dvect
;
234 SCM_SETCHARS (v
, (char *) scm_must_malloc (i
? i
: 1, "vector"));
235 SCM_SETLENGTH (v
, (k
< SCM_LENGTH_MAX
? k
: SCM_LENGTH_MAX
), type
);
240 GUILE_PROC(scm_uniform_vector_length
, "uniform-vector-length", 1, 0, 0,
243 #define FUNC_NAME s_scm_uniform_vector_length
245 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
250 badarg1
:SCM_WTA(1,v
);
262 #ifdef HAVE_LONG_LONGS
265 return SCM_MAKINUM (SCM_LENGTH (v
));
270 GUILE_PROC(scm_array_p
, "array?", 1, 1, 0,
273 #define FUNC_NAME s_scm_array_p
277 nprot
= SCM_UNBNDP (prot
);
282 switch (SCM_TYP7 (v
))
294 return nprot
|| SCM_BOOL(SCM_BOOL_T
==prot
);
296 return nprot
|| SCM_BOOL(SCM_ICHRP(prot
) && (prot
!= SCM_MAKICHR('\0')));
298 return nprot
|| SCM_BOOL(prot
== SCM_MAKICHR('\0'));
300 return nprot
|| SCM_BOOL(SCM_INUMP(prot
) && SCM_INUM(prot
)>0);
302 return nprot
|| SCM_BOOL(SCM_INUMP(prot
) && SCM_INUM(prot
)<=0);
306 && SCM_SYMBOLP (prot
)
307 && (1 == SCM_LENGTH (prot
))
308 && ('s' == SCM_CHARS (prot
)[0])));
309 #ifdef HAVE_LONG_LONGS
313 && SCM_SYMBOLP (prot
)
314 && (1 == SCM_LENGTH (prot
))
315 && ('s' == SCM_CHARS (prot
)[0])));
320 return nprot
|| SCM_BOOL(SCM_NIMP(prot
) && SCM_SINGP(prot
));
323 return nprot
|| SCM_BOOL(SCM_NIMP(prot
) && SCM_REALP(prot
));
325 return nprot
|| SCM_BOOL(SCM_NIMP(prot
) && SCM_CPLXP(prot
));
329 return nprot
|| SCM_BOOL(SCM_NULLP(prot
));
337 GUILE_PROC(scm_array_rank
, "array-rank", 1, 0, 0,
340 #define FUNC_NAME s_scm_array_rank
344 switch (SCM_TYP7 (ra
))
357 #ifdef HAVE_LONG_LONGS
361 return SCM_MAKINUM (1L);
364 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra
));
371 GUILE_PROC(scm_array_dimensions
, "array-dimensions", 1, 0, 0,
374 #define FUNC_NAME s_scm_array_dimensions
381 switch (SCM_TYP7 (ra
))
396 #ifdef HAVE_LONG_LONGS
399 return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra
)), SCM_EOL
);
401 if (!SCM_ARRAYP (ra
))
403 k
= SCM_ARRAY_NDIM (ra
);
404 s
= SCM_ARRAY_DIMS (ra
);
406 res
= scm_cons (s
[k
].lbnd
? scm_cons2 (SCM_MAKINUM (s
[k
].lbnd
), SCM_MAKINUM (s
[k
].ubnd
), SCM_EOL
) :
407 SCM_MAKINUM (1 + (s
[k
].ubnd
))
415 static char s_bad_ind
[] = "Bad scm_array index";
419 scm_aind (SCM ra
, SCM args
, const char *what
)
423 register scm_sizet pos
= SCM_ARRAY_BASE (ra
);
424 register scm_sizet k
= SCM_ARRAY_NDIM (ra
);
425 scm_array_dim
*s
= SCM_ARRAY_DIMS (ra
);
426 if (SCM_INUMP (args
))
428 SCM_ASSERT (1 == k
, scm_makfrom0str (what
), SCM_WNA
, NULL
);
429 return pos
+ (SCM_INUM (args
) - s
->lbnd
) * (s
->inc
);
431 while (k
&& SCM_NIMP (args
))
433 ind
= SCM_CAR (args
);
434 args
= SCM_CDR (args
);
435 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, what
);
437 SCM_ASSERT (j
>= (s
->lbnd
) && j
<= (s
->ubnd
), ind
, SCM_OUTOFRANGE
, what
);
438 pos
+= (j
- s
->lbnd
) * (s
->inc
);
442 SCM_ASSERT (0 == k
&& SCM_NULLP (args
), scm_makfrom0str (what
), SCM_WNA
,
450 scm_make_ra (int ndim
)
455 SCM_NEWSMOB(ra
, ((long) ndim
<< 17) + scm_tc16_array
,
456 scm_must_malloc ((long) (sizeof (scm_array
) + ndim
* sizeof (scm_array_dim
)),
458 SCM_ARRAY_V (ra
) = scm_nullvect
;
463 static char s_bad_spec
[] = "Bad scm_array dimension";
464 /* Increments will still need to be set. */
468 scm_shap2ra (SCM args
, const char *what
)
472 int ndim
= scm_ilength (args
);
473 SCM_ASSERT (0 <= ndim
, args
, s_bad_spec
, what
);
474 ra
= scm_make_ra (ndim
);
475 SCM_ARRAY_BASE (ra
) = 0;
476 s
= SCM_ARRAY_DIMS (ra
);
477 for (; SCM_NIMP (args
); s
++, args
= SCM_CDR (args
))
479 spec
= SCM_CAR (args
);
483 SCM_ASSERT (SCM_INUMP (spec
) && SCM_INUM (spec
) >= 0, spec
,
486 s
->ubnd
= SCM_INUM (spec
) - 1;
491 SCM_ASSERT (SCM_CONSP (spec
) && SCM_INUMP (SCM_CAR (spec
)), spec
,
493 s
->lbnd
= SCM_INUM (SCM_CAR (spec
));
495 SCM_ASSERT (SCM_NIMP (sp
) && SCM_CONSP (sp
)
496 && SCM_INUMP (SCM_CAR (sp
)) && SCM_NULLP (SCM_CDR (sp
)),
497 spec
, s_bad_spec
, what
);
498 s
->ubnd
= SCM_INUM (SCM_CAR (sp
));
505 GUILE_PROC(scm_dimensions_to_uniform_array
, "dimensions->uniform-array", 2, 1, 0,
506 (SCM dims
, SCM prot
, SCM fill
),
508 #define FUNC_NAME s_scm_dimensions_to_uniform_array
510 scm_sizet k
, vlen
= 1;
514 if (SCM_INUMP (dims
))
516 if (SCM_INUM (dims
) < SCM_LENGTH_MAX
)
518 SCM answer
= scm_make_uve (SCM_INUM (dims
), prot
);
520 if (!SCM_UNBNDP (fill
))
521 scm_array_fill_x (answer
, fill
);
522 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
))
523 scm_array_fill_x (answer
, SCM_MAKINUM (0));
525 scm_array_fill_x (answer
, prot
);
529 dims
= scm_cons (dims
, SCM_EOL
);
531 SCM_ASSERT (SCM_NULLP (dims
) || (SCM_NIMP (dims
) && SCM_CONSP (dims
)),
532 dims
, SCM_ARG1
, FUNC_NAME
);
533 ra
= scm_shap2ra (dims
, FUNC_NAME
);
534 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
535 s
= SCM_ARRAY_DIMS (ra
);
536 k
= SCM_ARRAY_NDIM (ra
);
539 s
[k
].inc
= (rlen
> 0 ? rlen
: 0);
540 rlen
= (s
[k
].ubnd
- s
[k
].lbnd
+ 1) * s
[k
].inc
;
541 vlen
*= (s
[k
].ubnd
- s
[k
].lbnd
+ 1);
543 if (rlen
< SCM_LENGTH_MAX
)
544 SCM_ARRAY_V (ra
) = scm_make_uve ((rlen
> 0 ? rlen
: 0L), prot
);
548 switch (SCM_TYP7 (scm_make_uve (0L, prot
)))
560 bit
= sizeof (float) * SCM_CHAR_BIT
/ sizeof (char);
563 bit
= sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
566 bit
= 2 * sizeof (double) * SCM_CHAR_BIT
/ sizeof (char);
569 SCM_ARRAY_BASE (ra
) = (SCM_LONG_BIT
+ bit
- 1) / bit
;
570 rlen
+= SCM_ARRAY_BASE (ra
);
571 SCM_ARRAY_V (ra
) = scm_make_uve (rlen
, prot
);
572 *((long *) SCM_VELTS (SCM_ARRAY_V (ra
))) = rlen
;
574 if (!SCM_UNBNDP (fill
))
576 scm_array_fill_x (ra
, fill
);
578 else if (SCM_NIMP (prot
) && SCM_SYMBOLP (prot
))
579 scm_array_fill_x (ra
, SCM_MAKINUM (0));
581 scm_array_fill_x (ra
, prot
);
582 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
583 if (s
->ubnd
< s
->lbnd
|| (0 == s
->lbnd
&& 1 == s
->inc
))
584 return SCM_ARRAY_V (ra
);
591 scm_ra_set_contp (SCM ra
)
593 scm_sizet k
= SCM_ARRAY_NDIM (ra
);
596 long inc
= SCM_ARRAY_DIMS (ra
)[k
- 1].inc
;
599 if (inc
!= SCM_ARRAY_DIMS (ra
)[k
].inc
)
601 SCM_SETAND_CAR (ra
, ~SCM_ARRAY_CONTIGUOUS
);
604 inc
*= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
605 - SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
608 SCM_SETOR_CAR (ra
, SCM_ARRAY_CONTIGUOUS
);
612 GUILE_PROC(scm_make_shared_array
, "make-shared-array", 2, 0, 1,
613 (SCM oldra
, SCM mapfunc
, SCM dims
),
615 #define FUNC_NAME s_scm_make_shared_array
621 long old_min
, new_min
, old_max
, new_max
;
623 SCM_VALIDATE_ARRAY(1,oldra
);
624 SCM_VALIDATE_PROC(2,mapfunc
);
625 ra
= scm_shap2ra (dims
, FUNC_NAME
);
626 if (SCM_ARRAYP (oldra
))
628 SCM_ARRAY_V (ra
) = SCM_ARRAY_V (oldra
);
629 old_min
= old_max
= SCM_ARRAY_BASE (oldra
);
630 s
= SCM_ARRAY_DIMS (oldra
);
631 k
= SCM_ARRAY_NDIM (oldra
);
635 old_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
637 old_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
642 SCM_ARRAY_V (ra
) = oldra
;
644 old_max
= (long) SCM_LENGTH (oldra
) - 1;
647 s
= SCM_ARRAY_DIMS (ra
);
648 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
650 inds
= scm_cons (SCM_MAKINUM (s
[k
].lbnd
), inds
);
651 if (s
[k
].ubnd
< s
[k
].lbnd
)
653 if (1 == SCM_ARRAY_NDIM (ra
))
654 ra
= scm_make_uve (0L, scm_array_prototype (ra
));
656 SCM_ARRAY_V (ra
) = scm_make_uve (0L, scm_array_prototype (ra
));
660 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
661 if (SCM_ARRAYP (oldra
))
662 i
= (scm_sizet
) scm_aind (oldra
, imap
, FUNC_NAME
);
665 if (SCM_NINUMP (imap
))
668 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
669 imap
, s_bad_ind
, FUNC_NAME
);
670 imap
= SCM_CAR (imap
);
674 SCM_ARRAY_BASE (ra
) = new_min
= new_max
= i
;
676 k
= SCM_ARRAY_NDIM (ra
);
679 if (s
[k
].ubnd
> s
[k
].lbnd
)
681 SCM_SETCAR (indptr
, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr
)) + 1));
682 imap
= scm_apply (mapfunc
, scm_reverse (inds
), SCM_EOL
);
683 if (SCM_ARRAYP (oldra
))
685 s
[k
].inc
= scm_aind (oldra
, imap
, FUNC_NAME
) - i
;
688 if (SCM_NINUMP (imap
))
691 SCM_ASSERT (1 == scm_ilength (imap
) && SCM_INUMP (SCM_CAR (imap
)),
692 imap
, s_bad_ind
, FUNC_NAME
);
693 imap
= SCM_CAR (imap
);
695 s
[k
].inc
= (long) SCM_INUM (imap
) - i
;
699 new_max
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
701 new_min
+= (s
[k
].ubnd
- s
[k
].lbnd
) * s
[k
].inc
;
704 s
[k
].inc
= new_max
- new_min
+ 1; /* contiguous by default */
705 indptr
= SCM_CDR (indptr
);
707 SCM_ASSERT (old_min
<= new_min
&& old_max
>= new_max
, SCM_UNDEFINED
,
708 "mapping out of range", FUNC_NAME
);
709 if (1 == SCM_ARRAY_NDIM (ra
) && 0 == SCM_ARRAY_BASE (ra
))
711 if (1 == s
->inc
&& 0 == s
->lbnd
712 && SCM_LENGTH (SCM_ARRAY_V (ra
)) == 1 + s
->ubnd
)
713 return SCM_ARRAY_V (ra
);
714 if (s
->ubnd
< s
->lbnd
)
715 return scm_make_uve (0L, scm_array_prototype (ra
));
717 scm_ra_set_contp (ra
);
723 /* args are RA . DIMS */
724 GUILE_PROC(scm_transpose_array
, "transpose-array", 0, 0, 1,
727 #define FUNC_NAME s_scm_transpose_array
729 SCM ra
, res
, vargs
, *ve
= &vargs
;
730 scm_array_dim
*s
, *r
;
732 SCM_ASSERT (SCM_NNULLP (args
), scm_makfrom0str (FUNC_NAME
),
735 SCM_ASSERT (SCM_NIMP (ra
), ra
, SCM_ARG1
, FUNC_NAME
);
736 args
= SCM_CDR (args
);
737 switch (SCM_TYP7 (ra
))
740 badarg
:SCM_WTA (1,ra
);
750 #ifdef HAVE_LONG_LONGS
753 SCM_ASSERT (SCM_NIMP (args
) && SCM_NULLP (SCM_CDR (args
)),
754 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
755 SCM_ASSERT (SCM_INUMP (SCM_CAR (args
)), SCM_CAR (args
), SCM_ARG2
,
757 SCM_ASSERT (SCM_INUM0
== SCM_CAR (args
), SCM_CAR (args
), SCM_OUTOFRANGE
,
761 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
762 vargs
= scm_vector (args
);
763 SCM_ASSERT (SCM_LENGTH (vargs
) == SCM_ARRAY_NDIM (ra
),
764 scm_makfrom0str (FUNC_NAME
), SCM_WNA
, NULL
);
765 ve
= SCM_VELTS (vargs
);
767 for (k
= 0; k
< SCM_ARRAY_NDIM (ra
); k
++)
769 SCM_ASSERT (SCM_INUMP (ve
[k
]), ve
[k
], (SCM_ARG2
+ k
),
771 i
= SCM_INUM (ve
[k
]);
772 SCM_ASSERT (i
>= 0 && i
< SCM_ARRAY_NDIM (ra
), ve
[k
],
773 SCM_OUTOFRANGE
, FUNC_NAME
);
778 res
= scm_make_ra (ndim
);
779 SCM_ARRAY_V (res
) = SCM_ARRAY_V (ra
);
780 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra
);
783 SCM_ARRAY_DIMS (res
)[k
].lbnd
= 0;
784 SCM_ARRAY_DIMS (res
)[k
].ubnd
= -1;
786 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
788 i
= SCM_INUM (ve
[k
]);
789 s
= &(SCM_ARRAY_DIMS (ra
)[k
]);
790 r
= &(SCM_ARRAY_DIMS (res
)[i
]);
791 if (r
->ubnd
< r
->lbnd
)
800 if (r
->ubnd
> s
->ubnd
)
802 if (r
->lbnd
< s
->lbnd
)
804 SCM_ARRAY_BASE (res
) += (s
->lbnd
- r
->lbnd
) * r
->inc
;
810 SCM_ASSERT (ndim
<= 0, args
, "bad argument list", FUNC_NAME
);
811 scm_ra_set_contp (res
);
817 /* args are RA . AXES */
818 GUILE_PROC(scm_enclose_array
, "enclose-array", 0, 0, 1,
821 #define FUNC_NAME s_scm_enclose_array
823 SCM axv
, ra
, res
, ra_inr
;
824 scm_array_dim vdim
, *s
= &vdim
;
825 int ndim
, j
, k
, ninr
, noutr
;
826 SCM_ASSERT (SCM_NIMP (axes
), scm_makfrom0str (FUNC_NAME
), SCM_WNA
,
829 axes
= SCM_CDR (axes
);
830 if (SCM_NULLP (axes
))
831 axes
= scm_cons ((SCM_ARRAYP (ra
) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra
) - 1) : SCM_INUM0
), SCM_EOL
);
832 ninr
= scm_ilength (axes
);
833 ra_inr
= scm_make_ra (ninr
);
834 SCM_ASRTGO (SCM_NIMP (ra
), badarg1
);
839 badarg1
:SCM_WTA (1,ra
);
851 #ifdef HAVE_LONG_LONGS
855 s
->ubnd
= SCM_LENGTH (ra
) - 1;
857 SCM_ARRAY_V (ra_inr
) = ra
;
858 SCM_ARRAY_BASE (ra_inr
) = 0;
862 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg1
);
863 s
= SCM_ARRAY_DIMS (ra
);
864 SCM_ARRAY_V (ra_inr
) = SCM_ARRAY_V (ra
);
865 SCM_ARRAY_BASE (ra_inr
) = SCM_ARRAY_BASE (ra
);
866 ndim
= SCM_ARRAY_NDIM (ra
);
870 axv
= scm_make_string (SCM_MAKINUM (ndim
), SCM_MAKICHR (0));
871 SCM_ASSERT (0 <= noutr
&& 0 <= ninr
, scm_makfrom0str (FUNC_NAME
),
873 res
= scm_make_ra (noutr
);
874 SCM_ARRAY_BASE (res
) = SCM_ARRAY_BASE (ra_inr
);
875 SCM_ARRAY_V (res
) = ra_inr
;
876 for (k
= 0; k
< ninr
; k
++, axes
= SCM_CDR (axes
))
878 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes
)), SCM_CAR (axes
), "bad axis", FUNC_NAME
);
879 j
= SCM_INUM (SCM_CAR (axes
));
880 SCM_ARRAY_DIMS (ra_inr
)[k
].lbnd
= s
[j
].lbnd
;
881 SCM_ARRAY_DIMS (ra_inr
)[k
].ubnd
= s
[j
].ubnd
;
882 SCM_ARRAY_DIMS (ra_inr
)[k
].inc
= s
[j
].inc
;
883 SCM_CHARS (axv
)[j
] = 1;
885 for (j
= 0, k
= 0; k
< noutr
; k
++, j
++)
887 while (SCM_CHARS (axv
)[j
])
889 SCM_ARRAY_DIMS (res
)[k
].lbnd
= s
[j
].lbnd
;
890 SCM_ARRAY_DIMS (res
)[k
].ubnd
= s
[j
].ubnd
;
891 SCM_ARRAY_DIMS (res
)[k
].inc
= s
[j
].inc
;
893 scm_ra_set_contp (ra_inr
);
894 scm_ra_set_contp (res
);
901 GUILE_PROC(scm_array_in_bounds_p
, "array-in-bounds?", 0, 0, 1,
904 #define FUNC_NAME s_scm_array_in_bounds_p
906 SCM v
, ind
= SCM_EOL
;
908 register scm_sizet k
;
911 SCM_ASSERT (SCM_NIMP (args
), scm_makfrom0str (FUNC_NAME
),
914 args
= SCM_CDR (args
);
915 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
919 ind
= SCM_CAR (args
);
920 args
= SCM_CDR (args
);
921 SCM_ASSERT (SCM_INUMP (ind
), ind
, SCM_ARG2
, FUNC_NAME
);
922 pos
= SCM_INUM (ind
);
929 badarg1
:SCM_WTA (1,v
);
930 wna
: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME
));
932 k
= SCM_ARRAY_NDIM (v
);
933 s
= SCM_ARRAY_DIMS (v
);
934 pos
= SCM_ARRAY_BASE (v
);
937 SCM_ASRTGO (SCM_NULLP (ind
), wna
);
944 if (!(j
>= (s
->lbnd
) && j
<= (s
->ubnd
)))
946 SCM_ASRTGO (--k
== scm_ilength (args
), wna
);
949 pos
+= (j
- s
->lbnd
) * (s
->inc
);
950 if (!(--k
&& SCM_NIMP (args
)))
952 ind
= SCM_CAR (args
);
953 args
= SCM_CDR (args
);
955 SCM_ASSERT (SCM_INUMP (ind
), ind
, s_bad_ind
, FUNC_NAME
);
957 SCM_ASRTGO (0 == k
, wna
);
969 #ifdef HAVE_LONG_LONGS
974 SCM_ASRTGO (SCM_NULLP (args
) && SCM_INUMP (ind
), wna
);
975 return SCM_BOOL(pos
>= 0 && pos
< SCM_LENGTH (v
));
981 SCM_REGISTER_PROC(s_array_ref
, "array-ref", 1, 0, 1, scm_uniform_vector_ref
);
984 GUILE_PROC(scm_uniform_vector_ref
, "uniform-vector-ref", 2, 0, 0,
987 #define FUNC_NAME s_scm_uniform_vector_ref
993 SCM_ASRTGO (SCM_NULLP (args
), badarg
);
996 else if (SCM_ARRAYP (v
))
998 pos
= scm_aind (v
, args
, FUNC_NAME
);
1003 if (SCM_NIMP (args
))
1006 SCM_ASSERT (SCM_CONSP (args
) && SCM_INUMP (SCM_CAR (args
)), args
, SCM_ARG2
, FUNC_NAME
);
1007 pos
= SCM_INUM (SCM_CAR (args
));
1008 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1012 SCM_VALIDATE_INT(2,args
);
1013 pos
= SCM_INUM (args
);
1015 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1021 if (SCM_NULLP (args
))
1026 outrng
:scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1027 wna
: scm_wrong_num_args (SCM_FUNC_NAME
);
1030 int k
= SCM_ARRAY_NDIM (v
);
1031 SCM res
= scm_make_ra (k
);
1032 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1033 SCM_ARRAY_BASE (res
) = pos
;
1036 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1037 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1038 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1043 if (SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] & (1L << (pos
% SCM_LONG_BIT
)))
1047 case scm_tc7_string
:
1048 return SCM_MAKICHR (SCM_UCHARS (v
)[pos
]);
1049 case scm_tc7_byvect
:
1050 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1051 # ifdef SCM_INUMS_ONLY
1054 return SCM_MAKINUM (SCM_VELTS (v
)[pos
]);
1057 return scm_ulong2num(SCM_VELTS(v
)[pos
]);
1059 return scm_long2num(SCM_VELTS(v
)[pos
]);
1063 return SCM_MAKINUM (((short *) SCM_CDR (v
))[pos
]);
1064 #ifdef HAVE_LONG_LONGS
1065 case scm_tc7_llvect
:
1066 return scm_long_long2num (((long_long
*) SCM_CDR (v
))[pos
]);
1072 return scm_makflo (((float *) SCM_CDR (v
))[pos
]);
1075 return scm_makdbl (((double *) SCM_CDR (v
))[pos
], 0.0);
1077 return scm_makdbl (((double *) SCM_CDR (v
))[2 * pos
],
1078 ((double *) SCM_CDR (v
))[2 * pos
+ 1]);
1080 case scm_tc7_vector
:
1082 return SCM_VELTS (v
)[pos
];
1087 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1088 tries to recycle conses. (Make *sure* you want them recycled.) */
1091 scm_cvref (SCM v
, scm_sizet pos
, SCM last
)
1096 scm_wta (v
, (char *) SCM_ARG1
, "PROGRAMMING ERROR: scm_cvref");
1098 if (SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] & (1L << (pos
% SCM_LONG_BIT
)))
1102 case scm_tc7_string
:
1103 return SCM_MAKICHR (SCM_UCHARS (v
)[pos
]);
1104 case scm_tc7_byvect
:
1105 return SCM_MAKINUM (((char *)SCM_CHARS (v
))[pos
]);
1106 # ifdef SCM_INUMS_ONLY
1109 return SCM_MAKINUM (SCM_VELTS (v
)[pos
]);
1112 return scm_ulong2num(SCM_VELTS(v
)[pos
]);
1114 return scm_long2num(SCM_VELTS(v
)[pos
]);
1117 return SCM_MAKINUM (((short *) SCM_CDR (v
))[pos
]);
1118 #ifdef HAVE_LONG_LONGS
1119 case scm_tc7_llvect
:
1120 return scm_long_long2num (((long_long
*) SCM_CDR (v
))[pos
]);
1125 if (SCM_NIMP (last
) && (last
!= scm_flo0
) && (scm_tc_flo
== SCM_CAR (last
)))
1127 SCM_FLO (last
) = ((float *) SCM_CDR (v
))[pos
];
1130 return scm_makflo (((float *) SCM_CDR (v
))[pos
]);
1134 if (SCM_NIMP (last
) && scm_tc_dblr
== SCM_CAR (last
))
1136 if (SCM_NIMP (last
) && (last
!= scm_flo0
) && (scm_tc_dblr
== SCM_CAR (last
)))
1139 SCM_REAL (last
) = ((double *) SCM_CDR (v
))[pos
];
1142 return scm_makdbl (((double *) SCM_CDR (v
))[pos
], 0.0);
1144 if (SCM_NIMP (last
) && scm_tc_dblc
== SCM_CAR (last
))
1146 SCM_REAL (last
) = ((double *) SCM_CDR (v
))[2 * pos
];
1147 SCM_IMAG (last
) = ((double *) SCM_CDR (v
))[2 * pos
+ 1];
1150 return scm_makdbl (((double *) SCM_CDR (v
))[2 * pos
],
1151 ((double *) SCM_CDR (v
))[2 * pos
+ 1]);
1153 case scm_tc7_vector
:
1155 return SCM_VELTS (v
)[pos
];
1157 { /* enclosed scm_array */
1158 int k
= SCM_ARRAY_NDIM (v
);
1159 SCM res
= scm_make_ra (k
);
1160 SCM_ARRAY_V (res
) = SCM_ARRAY_V (v
);
1161 SCM_ARRAY_BASE (res
) = pos
;
1164 SCM_ARRAY_DIMS (res
)[k
].ubnd
= SCM_ARRAY_DIMS (v
)[k
].ubnd
;
1165 SCM_ARRAY_DIMS (res
)[k
].lbnd
= SCM_ARRAY_DIMS (v
)[k
].lbnd
;
1166 SCM_ARRAY_DIMS (res
)[k
].inc
= SCM_ARRAY_DIMS (v
)[k
].inc
;
1173 SCM_REGISTER_PROC(s_uniform_array_set1_x
, "uniform-array-set1!", 3, 0, 0, scm_array_set_x
);
1176 /* Note that args may be a list or an immediate object, depending which
1177 PROC is used (and it's called from C too). */
1178 GUILE_PROC(scm_array_set_x
, "array-set!", 2, 0, 1,
1179 (SCM v
, SCM obj
, SCM args
),
1181 #define FUNC_NAME s_scm_array_set_x
1184 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1187 pos
= scm_aind (v
, args
, FUNC_NAME
);
1188 v
= SCM_ARRAY_V (v
);
1192 if (SCM_NIMP (args
))
1194 SCM_ASSERT (SCM_CONSP(args
) && SCM_INUMP (SCM_CAR (args
)), args
,
1195 SCM_ARG3
, FUNC_NAME
);
1196 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args
)), wna
);
1197 pos
= SCM_INUM (SCM_CAR (args
));
1201 SCM_VALIDATE_INT_COPY(3,args
,pos
);
1203 SCM_ASRTGO (pos
>= 0 && pos
< SCM_LENGTH (v
), outrng
);
1205 switch (SCM_TYP7 (v
))
1210 outrng
:scm_out_of_range (FUNC_NAME
, SCM_MAKINUM (pos
));
1211 wna
: scm_wrong_num_args (SCM_FUNC_NAME
);
1212 case scm_tc7_smob
: /* enclosed */
1215 if (SCM_BOOL_F
== obj
)
1216 SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] &= ~(1L << (pos
% SCM_LONG_BIT
));
1217 else if (SCM_BOOL_T
== obj
)
1218 SCM_VELTS (v
)[pos
/ SCM_LONG_BIT
] |= (1L << (pos
% SCM_LONG_BIT
));
1220 badobj
:SCM_WTA (2,obj
);
1222 case scm_tc7_string
:
1223 SCM_ASRTGO (SCM_ICHRP (obj
), badobj
);
1224 SCM_UCHARS (v
)[pos
] = SCM_ICHR (obj
);
1226 case scm_tc7_byvect
:
1227 if (SCM_ICHRP (obj
))
1228 obj
= SCM_MAKINUM ((char) SCM_ICHR (obj
));
1229 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1230 ((char *)SCM_CHARS (v
))[pos
] = SCM_INUM (obj
);
1232 # ifdef SCM_INUMS_ONLY
1234 SCM_ASRTGO (SCM_INUM (obj
) >= 0, badobj
);
1237 SCM_ASRTGO(SCM_INUMP(obj
), badobj
); SCM_VELTS(v
)[pos
] = SCM_INUM(obj
); break;
1240 SCM_VELTS(v
)[pos
] = scm_num2ulong(obj
, (char *)SCM_ARG2
, FUNC_NAME
); break;
1242 SCM_VELTS(v
)[pos
] = scm_num2long(obj
, (char *)SCM_ARG2
, FUNC_NAME
); break;
1245 SCM_ASRTGO (SCM_INUMP (obj
), badobj
);
1246 ((short *) SCM_CDR (v
))[pos
] = SCM_INUM (obj
);
1248 #ifdef HAVE_LONG_LONGS
1249 case scm_tc7_llvect
:
1250 ((long_long
*) SCM_CDR (v
))[pos
] = scm_num2long_long (obj
, (char *)SCM_ARG2
, FUNC_NAME
);
1258 ((float *) SCM_CDR (v
))[pos
] = (float)scm_num2dbl(obj
, FUNC_NAME
); break;
1262 ((double *) SCM_CDR (v
))[pos
] = scm_num2dbl(obj
, FUNC_NAME
); break;
1265 SCM_ASRTGO (SCM_NIMP (obj
) && SCM_INEXP (obj
), badobj
);
1266 ((double *) SCM_CDR (v
))[2 * pos
] = SCM_REALPART (obj
);
1267 ((double *) SCM_CDR (v
))[2 * pos
+ 1] = SCM_CPLXP (obj
) ? SCM_IMAG (obj
) : 0.0;
1270 case scm_tc7_vector
:
1272 SCM_VELTS (v
)[pos
] = obj
;
1275 return SCM_UNSPECIFIED
;
1279 /* attempts to unroll an array into a one-dimensional array.
1280 returns the unrolled array or #f if it can't be done. */
1281 /* if strict is not SCM_UNDEFINED, return #f if returned array
1282 wouldn't have contiguous elements. */
1283 GUILE_PROC(scm_array_contents
, "array-contents", 1, 1, 0,
1284 (SCM ra
, SCM strict
),
1286 #define FUNC_NAME s_scm_array_contents
1291 switch SCM_TYP7 (ra
)
1295 case scm_tc7_vector
:
1297 case scm_tc7_string
:
1299 case scm_tc7_byvect
:
1306 #ifdef HAVE_LONG_LONGS
1307 case scm_tc7_llvect
:
1312 scm_sizet k
, ndim
= SCM_ARRAY_NDIM (ra
), len
= 1;
1313 if (!SCM_ARRAYP (ra
) || !SCM_ARRAY_CONTP (ra
))
1315 for (k
= 0; k
< ndim
; k
++)
1316 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1317 if (!SCM_UNBNDP (strict
))
1319 if (ndim
&& (1 != SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
))
1321 if (scm_tc7_bvect
== SCM_TYP7 (SCM_ARRAY_V (ra
)))
1323 if (len
!= SCM_LENGTH (SCM_ARRAY_V (ra
)) ||
1324 SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
||
1329 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
))) && 0 == SCM_ARRAY_BASE (ra
) && SCM_ARRAY_DIMS (ra
)->inc
)
1330 return SCM_ARRAY_V (ra
);
1331 sra
= scm_make_ra (1);
1332 SCM_ARRAY_DIMS (sra
)->lbnd
= 0;
1333 SCM_ARRAY_DIMS (sra
)->ubnd
= len
- 1;
1334 SCM_ARRAY_V (sra
) = SCM_ARRAY_V (ra
);
1335 SCM_ARRAY_BASE (sra
) = SCM_ARRAY_BASE (ra
);
1336 SCM_ARRAY_DIMS (sra
)->inc
= (ndim
? SCM_ARRAY_DIMS (ra
)[ndim
- 1].inc
: 1);
1345 scm_ra2contig (SCM ra
, int copy
)
1349 scm_sizet k
, len
= 1;
1350 for (k
= SCM_ARRAY_NDIM (ra
); k
--;)
1351 len
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1352 k
= SCM_ARRAY_NDIM (ra
);
1353 if (SCM_ARRAY_CONTP (ra
) && ((0 == k
) || (1 == SCM_ARRAY_DIMS (ra
)[k
- 1].inc
)))
1355 if (scm_tc7_bvect
!= SCM_TYP7 (ra
))
1357 if ((len
== SCM_LENGTH (SCM_ARRAY_V (ra
)) &&
1358 0 == SCM_ARRAY_BASE (ra
) % SCM_LONG_BIT
&&
1359 0 == len
% SCM_LONG_BIT
))
1362 ret
= scm_make_ra (k
);
1363 SCM_ARRAY_BASE (ret
) = 0;
1366 SCM_ARRAY_DIMS (ret
)[k
].lbnd
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
;
1367 SCM_ARRAY_DIMS (ret
)[k
].ubnd
= SCM_ARRAY_DIMS (ra
)[k
].ubnd
;
1368 SCM_ARRAY_DIMS (ret
)[k
].inc
= inc
;
1369 inc
*= SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1;
1371 SCM_ARRAY_V (ret
) = scm_make_uve ((inc
- 1), scm_array_prototype (ra
));
1373 scm_array_copy_x (ra
, ret
);
1379 GUILE_PROC(scm_uniform_array_read_x
, "uniform-array-read!", 1, 3, 0,
1380 (SCM ra
, SCM port_or_fd
, SCM start
, SCM end
),
1382 #define FUNC_NAME s_scm_uniform_array_read_x
1384 SCM cra
= SCM_UNDEFINED
, v
= ra
;
1390 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1391 if (SCM_UNBNDP (port_or_fd
))
1392 port_or_fd
= scm_cur_inp
;
1394 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1395 || (SCM_NIMP (port_or_fd
) && SCM_OPINPORTP (port_or_fd
)),
1396 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1397 vlen
= SCM_LENGTH (v
);
1403 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, FUNC_NAME
);
1405 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1406 cra
= scm_ra2contig (ra
, 0);
1407 cstart
+= SCM_ARRAY_BASE (cra
);
1408 vlen
= SCM_ARRAY_DIMS (cra
)->inc
*
1409 (SCM_ARRAY_DIMS (cra
)->ubnd
- SCM_ARRAY_DIMS (cra
)->lbnd
+ 1);
1410 v
= SCM_ARRAY_V (cra
);
1412 case scm_tc7_string
:
1413 case scm_tc7_byvect
:
1417 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1418 cstart
/= SCM_LONG_BIT
;
1424 sz
= sizeof (short);
1426 #ifdef HAVE_LONG_LONGS
1427 case scm_tc7_llvect
:
1428 sz
= sizeof (long_long
);
1434 sz
= sizeof (float);
1438 sz
= sizeof (double);
1441 sz
= 2 * sizeof (double);
1447 if (!SCM_UNBNDP (start
))
1450 scm_num2long (start
, (char *) SCM_ARG3
, FUNC_NAME
);
1452 if (offset
< 0 || offset
>= cend
)
1453 scm_out_of_range (FUNC_NAME
, start
);
1455 if (!SCM_UNBNDP (end
))
1458 scm_num2long (end
, (char *) SCM_ARG4
, FUNC_NAME
);
1460 if (tend
<= offset
|| tend
> cend
)
1461 scm_out_of_range (FUNC_NAME
, end
);
1466 if (SCM_NIMP (port_or_fd
))
1468 scm_port
*pt
= SCM_PTAB_ENTRY (port_or_fd
);
1469 int remaining
= (cend
- offset
) * sz
;
1470 char *dest
= SCM_CHARS (v
) + (cstart
+ offset
) * sz
;
1472 if (pt
->rw_active
== SCM_PORT_WRITE
)
1473 scm_flush (port_or_fd
);
1475 ans
= cend
- offset
;
1476 while (remaining
> 0)
1478 if (pt
->read_pos
< pt
->read_end
)
1480 int to_copy
= min (pt
->read_end
- pt
->read_pos
,
1483 memcpy (dest
, pt
->read_pos
, to_copy
);
1484 pt
->read_pos
+= to_copy
;
1485 remaining
-= to_copy
;
1490 if (scm_fill_input (port_or_fd
) == EOF
)
1492 if (remaining
% sz
!= 0)
1494 scm_misc_error (FUNC_NAME
,
1498 ans
-= remaining
/ sz
;
1505 pt
->rw_active
= SCM_PORT_READ
;
1507 else /* file descriptor. */
1509 SCM_SYSCALL (ans
= read (SCM_INUM (port_or_fd
),
1510 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1511 (scm_sizet
) (sz
* (cend
- offset
))));
1515 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1516 ans
*= SCM_LONG_BIT
;
1518 if (v
!= ra
&& cra
!= ra
)
1519 scm_array_copy_x (cra
, ra
);
1521 return SCM_MAKINUM (ans
);
1525 GUILE_PROC(scm_uniform_array_write
, "uniform-array-write", 1, 3, 0,
1526 (SCM v
, SCM port_or_fd
, SCM start
, SCM end
),
1528 #define FUNC_NAME s_scm_uniform_array_write
1535 port_or_fd
= SCM_COERCE_OUTPORT (port_or_fd
);
1537 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1538 if (SCM_UNBNDP (port_or_fd
))
1539 port_or_fd
= scm_cur_outp
;
1541 SCM_ASSERT (SCM_INUMP (port_or_fd
)
1542 || (SCM_NIMP (port_or_fd
) && SCM_OPOUTPORTP (port_or_fd
)),
1543 port_or_fd
, SCM_ARG2
, FUNC_NAME
);
1544 vlen
= SCM_LENGTH (v
);
1550 badarg1
:scm_wta (v
, (char *) SCM_ARG1
, FUNC_NAME
);
1552 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1553 v
= scm_ra2contig (v
, 1);
1554 cstart
= SCM_ARRAY_BASE (v
);
1555 vlen
= SCM_ARRAY_DIMS (v
)->inc
1556 * (SCM_ARRAY_DIMS (v
)->ubnd
- SCM_ARRAY_DIMS (v
)->lbnd
+ 1);
1557 v
= SCM_ARRAY_V (v
);
1559 case scm_tc7_string
:
1560 case scm_tc7_byvect
:
1564 vlen
= (vlen
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
;
1565 cstart
/= SCM_LONG_BIT
;
1571 sz
= sizeof (short);
1573 #ifdef HAVE_LONG_LONGS
1574 case scm_tc7_llvect
:
1575 sz
= sizeof (long_long
);
1581 sz
= sizeof (float);
1585 sz
= sizeof (double);
1588 sz
= 2 * sizeof (double);
1594 if (!SCM_UNBNDP (start
))
1597 scm_num2long (start
, (char *) SCM_ARG3
, FUNC_NAME
);
1599 if (offset
< 0 || offset
>= cend
)
1600 scm_out_of_range (FUNC_NAME
, start
);
1602 if (!SCM_UNBNDP (end
))
1605 scm_num2long (end
, (char *) SCM_ARG4
, FUNC_NAME
);
1607 if (tend
<= offset
|| tend
> cend
)
1608 scm_out_of_range (FUNC_NAME
, end
);
1613 if (SCM_NIMP (port_or_fd
))
1615 char *source
= SCM_CHARS (v
) + (cstart
+ offset
) * sz
;
1617 ans
= cend
- offset
;
1618 scm_lfwrite (source
, ans
* sz
, port_or_fd
);
1620 else /* file descriptor. */
1622 SCM_SYSCALL (ans
= write (SCM_INUM (port_or_fd
),
1623 SCM_CHARS (v
) + (cstart
+ offset
) * sz
,
1624 (scm_sizet
) (sz
* (cend
- offset
))));
1628 if (SCM_TYP7 (v
) == scm_tc7_bvect
)
1629 ans
*= SCM_LONG_BIT
;
1631 return SCM_MAKINUM (ans
);
1636 static char cnt_tab
[16] =
1637 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1639 GUILE_PROC(scm_bit_count
, "bit-count", 2, 0, 0,
1640 (SCM item
, SCM seq
),
1642 #define FUNC_NAME s_scm_bit_count
1645 register unsigned long cnt
= 0, w
;
1646 SCM_VALIDATE_INT(2,seq
);
1647 switch SCM_TYP7 (seq
)
1652 if (0 == SCM_LENGTH (seq
))
1654 i
= (SCM_LENGTH (seq
) - 1) / SCM_LONG_BIT
;
1655 w
= SCM_VELTS (seq
)[i
];
1656 if (SCM_FALSEP (item
))
1658 w
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (seq
) - 1) % SCM_LONG_BIT
);
1662 cnt
+= cnt_tab
[w
& 0x0f];
1664 return SCM_MAKINUM (cnt
);
1665 w
= SCM_VELTS (seq
)[i
];
1666 if (SCM_FALSEP (item
))
1674 GUILE_PROC(scm_bit_position
, "bit-position", 3, 0, 0,
1675 (SCM item
, SCM v
, SCM k
),
1677 #define FUNC_NAME s_scm_bit_position
1679 long i
, lenw
, xbits
, pos
;
1680 register unsigned long w
;
1681 SCM_VALIDATE_NIM (2,v
);
1682 SCM_VALIDATE_INT_COPY(3,k
,pos
);
1683 SCM_ASSERT ((pos
<= SCM_LENGTH (v
)) && (pos
>= 0),
1684 k
, SCM_OUTOFRANGE
, FUNC_NAME
);
1685 if (pos
== SCM_LENGTH (v
))
1692 if (0 == SCM_LENGTH (v
))
1693 return SCM_MAKINUM (-1L);
1694 lenw
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; /* watch for part words */
1695 i
= pos
/ SCM_LONG_BIT
;
1696 w
= SCM_VELTS (v
)[i
];
1697 if (SCM_FALSEP (item
))
1699 xbits
= (pos
% SCM_LONG_BIT
);
1701 w
= ((w
>> xbits
) << xbits
);
1702 xbits
= SCM_LONG_BIT
- 1 - (SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
;
1705 if (w
&& (i
== lenw
))
1706 w
= ((w
<< xbits
) >> xbits
);
1712 return SCM_MAKINUM (pos
);
1717 return SCM_MAKINUM (pos
+ 1);
1720 return SCM_MAKINUM (pos
+ 2);
1722 return SCM_MAKINUM (pos
+ 3);
1729 pos
+= SCM_LONG_BIT
;
1730 w
= SCM_VELTS (v
)[i
];
1731 if (SCM_FALSEP (item
))
1740 GUILE_PROC(scm_bit_set_star_x
, "bit-set*!", 3, 0, 0,
1741 (SCM v
, SCM kv
, SCM obj
),
1743 #define FUNC_NAME s_scm_bit_set_star_x
1745 register long i
, k
, vlen
;
1746 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1747 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1748 switch SCM_TYP7 (kv
)
1751 badarg2
:SCM_WTA (2,kv
);
1756 badarg1
:SCM_WTA (1,v
);
1758 vlen
= SCM_LENGTH (v
);
1759 if (SCM_BOOL_F
== obj
)
1760 for (i
= SCM_LENGTH (kv
); i
;)
1762 k
= SCM_VELTS (kv
)[--i
];
1763 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1764 SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] &= ~(1L << (k
% SCM_LONG_BIT
));
1766 else if (SCM_BOOL_T
== obj
)
1767 for (i
= SCM_LENGTH (kv
); i
;)
1769 k
= SCM_VELTS (kv
)[--i
];
1770 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1771 SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] |= (1L << (k
% SCM_LONG_BIT
));
1774 badarg3
:SCM_WTA (3,obj
);
1778 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1779 if (SCM_BOOL_F
== obj
)
1780 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1781 SCM_VELTS (v
)[k
] &= ~(SCM_VELTS (kv
)[k
]);
1782 else if (SCM_BOOL_T
== obj
)
1783 for (k
= (SCM_LENGTH (v
) + SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1784 SCM_VELTS (v
)[k
] |= SCM_VELTS (kv
)[k
];
1789 return SCM_UNSPECIFIED
;
1794 GUILE_PROC(scm_bit_count_star
, "bit-count*", 3, 0, 0,
1795 (SCM v
, SCM kv
, SCM obj
),
1797 #define FUNC_NAME s_scm_bit_count_star
1799 register long i
, vlen
, count
= 0;
1800 register unsigned long k
;
1801 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1802 SCM_ASRTGO (SCM_NIMP (kv
), badarg2
);
1803 switch SCM_TYP7 (kv
)
1806 badarg2
:SCM_WTA (2,kv
);
1812 badarg1
:SCM_WTA (1,v
);
1814 vlen
= SCM_LENGTH (v
);
1815 if (SCM_BOOL_F
== obj
)
1816 for (i
= SCM_LENGTH (kv
); i
;)
1818 k
= SCM_VELTS (kv
)[--i
];
1819 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1820 if (!(SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] & (1L << (k
% SCM_LONG_BIT
))))
1823 else if (SCM_BOOL_T
== obj
)
1824 for (i
= SCM_LENGTH (kv
); i
;)
1826 k
= SCM_VELTS (kv
)[--i
];
1827 SCM_ASSERT ((k
< vlen
), SCM_MAKINUM (k
), SCM_OUTOFRANGE
, FUNC_NAME
);
1828 if (SCM_VELTS (v
)[k
/ SCM_LONG_BIT
] & (1L << (k
% SCM_LONG_BIT
)))
1832 badarg3
:SCM_WTA (3,obj
);
1836 SCM_ASRTGO (SCM_TYP7 (v
) == scm_tc7_bvect
&& SCM_LENGTH (v
) == SCM_LENGTH (kv
), badarg1
);
1837 if (0 == SCM_LENGTH (v
))
1839 SCM_ASRTGO (SCM_BOOL_T
== obj
|| SCM_BOOL_F
== obj
, badarg3
);
1840 obj
= (SCM_BOOL_T
== obj
);
1841 i
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
;
1842 k
= SCM_VELTS (kv
)[i
] & (obj
? SCM_VELTS (v
)[i
] : ~SCM_VELTS (v
)[i
]);
1843 k
<<= SCM_LONG_BIT
- 1 - ((SCM_LENGTH (v
) - 1) % SCM_LONG_BIT
);
1847 count
+= cnt_tab
[k
& 0x0f];
1849 return SCM_MAKINUM (count
);
1850 k
= SCM_VELTS (kv
)[i
] & (obj
? SCM_VELTS (v
)[i
] : ~SCM_VELTS (v
)[i
]);
1853 return SCM_MAKINUM (count
);
1858 GUILE_PROC(scm_bit_invert_x
, "bit-invert!", 1, 0, 0,
1861 #define FUNC_NAME s_scm_bit_invert_x
1864 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1870 for (k
= (k
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
--;)
1871 SCM_VELTS (v
)[k
] = ~SCM_VELTS (v
)[k
];
1874 badarg1
:SCM_WTA (1,v
);
1876 return SCM_UNSPECIFIED
;
1882 scm_istr2bve (char *str
, long len
)
1884 SCM v
= scm_make_uve (len
, SCM_BOOL_T
);
1885 long *data
= (long *) SCM_VELTS (v
);
1886 register unsigned long mask
;
1889 for (k
= 0; k
< (len
+ SCM_LONG_BIT
- 1) / SCM_LONG_BIT
; k
++)
1892 j
= len
- k
* SCM_LONG_BIT
;
1893 if (j
> SCM_LONG_BIT
)
1895 for (mask
= 1L; j
--; mask
<<= 1)
1913 ra2l (SCM ra
,scm_sizet base
,scm_sizet k
)
1915 register SCM res
= SCM_EOL
;
1916 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
1917 register scm_sizet i
;
1918 if (SCM_ARRAY_DIMS (ra
)[k
].ubnd
< SCM_ARRAY_DIMS (ra
)[k
].lbnd
)
1920 i
= base
+ (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
) * inc
;
1921 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
1926 res
= scm_cons (ra2l (ra
, i
, k
+ 1), res
);
1934 res
= scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra
), SCM_MAKINUM (i
)), res
);
1941 GUILE_PROC(scm_array_to_list
, "array->list", 1, 0, 0,
1944 #define FUNC_NAME s_scm_array_to_list
1948 SCM_ASRTGO (SCM_NIMP (v
), badarg1
);
1953 badarg1
:SCM_WTA (1,v
);
1955 SCM_ASRTGO (SCM_ARRAYP (v
), badarg1
);
1956 return ra2l (v
, SCM_ARRAY_BASE (v
), 0);
1957 case scm_tc7_vector
:
1959 return scm_vector_to_list (v
);
1960 case scm_tc7_string
:
1961 return scm_string_to_list (v
);
1964 long *data
= (long *) SCM_VELTS (v
);
1965 register unsigned long mask
;
1966 for (k
= (SCM_LENGTH (v
) - 1) / SCM_LONG_BIT
; k
> 0; k
--)
1967 for (mask
= 1UL << (SCM_LONG_BIT
- 1); mask
; mask
>>= 1)
1968 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
1969 for (mask
= 1L << ((SCM_LENGTH (v
) % SCM_LONG_BIT
) - 1); mask
; mask
>>= 1)
1970 res
= scm_cons (SCM_BOOL(((long *) data
)[k
] & mask
), res
);
1973 # ifdef SCM_INUMS_ONLY
1977 long *data
= (long *) SCM_VELTS (v
);
1978 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
1979 res
= scm_cons (SCM_MAKINUM (data
[k
]), res
);
1983 case scm_tc7_uvect
: {
1984 long *data
= (long *)SCM_VELTS(v
);
1985 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
1986 res
= scm_cons(scm_ulong2num(data
[k
]), res
);
1989 case scm_tc7_ivect
: {
1990 long *data
= (long *)SCM_VELTS(v
);
1991 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
1992 res
= scm_cons(scm_long2num(data
[k
]), res
);
1996 case scm_tc7_svect
: {
1998 data
= (short *)SCM_VELTS(v
);
1999 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2000 res
= scm_cons(SCM_MAKINUM (data
[k
]), res
);
2003 #ifdef HAVE_LONG_LONGS
2004 case scm_tc7_llvect
: {
2006 data
= (long_long
*)SCM_VELTS(v
);
2007 for (k
= SCM_LENGTH(v
) - 1; k
>= 0; k
--)
2008 res
= scm_cons(scm_long_long2num(data
[k
]), res
);
2018 float *data
= (float *) SCM_VELTS (v
);
2019 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2020 res
= scm_cons (scm_makflo (data
[k
]), res
);
2023 #endif /*SCM_SINGLES*/
2026 double *data
= (double *) SCM_VELTS (v
);
2027 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2028 res
= scm_cons (scm_makdbl (data
[k
], 0.0), res
);
2033 double (*data
)[2] = (double (*)[2]) SCM_VELTS (v
);
2034 for (k
= SCM_LENGTH (v
) - 1; k
>= 0; k
--)
2035 res
= scm_cons (scm_makdbl (data
[k
][0], data
[k
][1]), res
);
2038 #endif /*SCM_FLOATS*/
2044 static char s_bad_ralst
[] = "Bad scm_array contents list";
2046 static int l2ra(SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
);
2048 GUILE_PROC(scm_list_to_uniform_array
, "list->uniform-array", 3, 0, 0,
2049 (SCM ndim
, SCM prot
, SCM lst
),
2051 #define FUNC_NAME s_scm_list_to_uniform_array
2058 SCM_VALIDATE_INT_COPY(1,ndim
,k
);
2061 n
= scm_ilength (row
);
2062 SCM_ASSERT (n
>= 0, lst
, SCM_ARG3
, FUNC_NAME
);
2063 shp
= scm_cons (SCM_MAKINUM (n
), shp
);
2065 row
= SCM_CAR (row
);
2067 ra
= scm_dimensions_to_uniform_array (scm_reverse (shp
), prot
,
2069 if (SCM_NULLP (shp
))
2072 SCM_ASRTGO (1 == scm_ilength (lst
), badlst
);
2073 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_EOL
);
2076 if (!SCM_ARRAYP (ra
))
2078 for (k
= 0; k
< SCM_LENGTH (ra
); k
++, lst
= SCM_CDR (lst
))
2079 scm_array_set_x (ra
, SCM_CAR (lst
), SCM_MAKINUM (k
));
2082 if (l2ra (lst
, ra
, SCM_ARRAY_BASE (ra
), 0))
2085 badlst
:scm_wta (lst
, s_bad_ralst
, FUNC_NAME
);
2091 l2ra (SCM lst
, SCM ra
, scm_sizet base
, scm_sizet k
)
2093 register long inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2094 register long n
= (1 + SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
);
2097 return (SCM_EOL
== lst
);
2098 if (k
< SCM_ARRAY_NDIM (ra
) - 1)
2102 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2104 ok
= ok
&& l2ra (SCM_CAR (lst
), ra
, base
, k
+ 1);
2106 lst
= SCM_CDR (lst
);
2108 if (SCM_NNULLP (lst
))
2115 if (SCM_IMP (lst
) || SCM_NCONSP (lst
))
2117 ok
= ok
&& scm_array_set_x (SCM_ARRAY_V (ra
), SCM_CAR (lst
), SCM_MAKINUM (base
));
2119 lst
= SCM_CDR (lst
);
2121 if (SCM_NNULLP (lst
))
2129 rapr1 (SCM ra
,scm_sizet j
,scm_sizet k
,SCM port
,scm_print_state
*pstate
)
2132 long n
= SCM_LENGTH (ra
);
2135 switch SCM_TYP7 (ra
)
2140 SCM_ARRAY_BASE (ra
) = j
;
2142 scm_iprin1 (ra
, port
, pstate
);
2143 for (j
+= inc
; n
-- > 0; j
+= inc
)
2145 scm_putc (' ', port
);
2146 SCM_ARRAY_BASE (ra
) = j
;
2147 scm_iprin1 (ra
, port
, pstate
);
2151 if (k
+ 1 < SCM_ARRAY_NDIM (ra
))
2154 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2155 for (i
= SCM_ARRAY_DIMS (ra
)[k
].lbnd
; i
< SCM_ARRAY_DIMS (ra
)[k
].ubnd
; i
++)
2157 scm_putc ('(', port
);
2158 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2159 scm_puts (") ", port
);
2162 if (i
== SCM_ARRAY_DIMS (ra
)[k
].ubnd
)
2163 { /* could be zero size. */
2164 scm_putc ('(', port
);
2165 rapr1 (ra
, j
, k
+ 1, port
, pstate
);
2166 scm_putc (')', port
);
2172 { /* Could be zero-dimensional */
2173 inc
= SCM_ARRAY_DIMS (ra
)[k
].inc
;
2174 n
= (SCM_ARRAY_DIMS (ra
)[k
].ubnd
- SCM_ARRAY_DIMS (ra
)[k
].lbnd
+ 1);
2178 ra
= SCM_ARRAY_V (ra
);
2181 /* scm_tc7_bvect and scm_tc7_llvect only? */
2183 scm_iprin1 (scm_uniform_vector_ref (ra
, SCM_MAKINUM (j
)), port
, pstate
);
2184 for (j
+= inc
; n
-- > 0; j
+= inc
)
2186 scm_putc (' ', port
);
2187 scm_iprin1 (scm_cvref (ra
, j
, SCM_UNDEFINED
), port
, pstate
);
2190 case scm_tc7_string
:
2192 scm_iprin1 (SCM_MAKICHR (SCM_UCHARS (ra
)[j
]), port
, pstate
);
2193 if (SCM_WRITINGP (pstate
))
2194 for (j
+= inc
; n
-- > 0; j
+= inc
)
2196 scm_putc (' ', port
);
2197 scm_iprin1 (SCM_MAKICHR (SCM_UCHARS (ra
)[j
]), port
, pstate
);
2200 for (j
+= inc
; n
-- > 0; j
+= inc
)
2201 scm_putc (SCM_CHARS (ra
)[j
], port
);
2203 case scm_tc7_byvect
:
2205 scm_intprint (((char *)SCM_CDR (ra
))[j
], 10, port
);
2206 for (j
+= inc
; n
-- > 0; j
+= inc
)
2208 scm_putc (' ', port
);
2209 scm_intprint (((char *)SCM_CDR (ra
))[j
], 10, port
);
2219 /* intprint can't handle >= 2^31. */
2220 sprintf (str
, "%lu", (unsigned long) SCM_VELTS (ra
)[j
]);
2221 scm_puts (str
, port
);
2223 for (j
+= inc
; n
-- > 0; j
+= inc
)
2225 scm_putc (' ', port
);
2226 sprintf (str
, "%lu", (unsigned long) SCM_VELTS (ra
)[j
]);
2227 scm_puts (str
, port
);
2232 scm_intprint (SCM_VELTS (ra
)[j
], 10, port
);
2233 for (j
+= inc
; n
-- > 0; j
+= inc
)
2235 scm_putc (' ', port
);
2236 scm_intprint (SCM_VELTS (ra
)[j
], 10, port
);
2242 scm_intprint (((short *)SCM_CDR (ra
))[j
], 10, port
);
2243 for (j
+= inc
; n
-- > 0; j
+= inc
)
2245 scm_putc (' ', port
);
2246 scm_intprint (((short *)SCM_CDR (ra
))[j
], 10, port
);
2255 SCM z
= scm_makflo (1.0);
2256 SCM_FLO (z
) = ((float *) SCM_VELTS (ra
))[j
];
2257 scm_floprint (z
, port
, pstate
);
2258 for (j
+= inc
; n
-- > 0; j
+= inc
)
2260 scm_putc (' ', port
);
2261 SCM_FLO (z
) = ((float *) SCM_VELTS (ra
))[j
];
2262 scm_floprint (z
, port
, pstate
);
2266 #endif /*SCM_SINGLES*/
2270 SCM z
= scm_makdbl (1.0 / 3.0, 0.0);
2271 SCM_REAL (z
) = ((double *) SCM_VELTS (ra
))[j
];
2272 scm_floprint (z
, port
, pstate
);
2273 for (j
+= inc
; n
-- > 0; j
+= inc
)
2275 scm_putc (' ', port
);
2276 SCM_REAL (z
) = ((double *) SCM_VELTS (ra
))[j
];
2277 scm_floprint (z
, port
, pstate
);
2284 SCM cz
= scm_makdbl (0.0, 1.0), z
= scm_makdbl (1.0 / 3.0, 0.0);
2285 SCM_REAL (z
) = SCM_REAL (cz
) = (((double *) SCM_VELTS (ra
))[2 * j
]);
2286 SCM_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2287 scm_floprint ((0.0 == SCM_IMAG (cz
) ? z
: cz
), port
, pstate
);
2288 for (j
+= inc
; n
-- > 0; j
+= inc
)
2290 scm_putc (' ', port
);
2291 SCM_REAL (z
) = SCM_REAL (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
];
2292 SCM_IMAG (cz
) = ((double *) SCM_VELTS (ra
))[2 * j
+ 1];
2293 scm_floprint ((0.0 == SCM_IMAG (cz
) ? z
: cz
), port
, pstate
);
2297 #endif /*SCM_FLOATS*/
2304 scm_raprin1 (SCM exp
, SCM port
, scm_print_state
*pstate
)
2308 scm_putc ('#', port
);
2314 long ndim
= SCM_ARRAY_NDIM (v
);
2315 base
= SCM_ARRAY_BASE (v
);
2316 v
= SCM_ARRAY_V (v
);
2320 scm_puts ("<enclosed-array ", port
);
2321 rapr1 (exp
, base
, 0, port
, pstate
);
2322 scm_putc ('>', port
);
2327 scm_intprint (ndim
, 10, port
);
2333 { /* a uve, not an scm_array */
2334 register long i
, j
, w
;
2335 scm_putc ('*', port
);
2336 for (i
= 0; i
< (SCM_LENGTH (exp
)) / SCM_LONG_BIT
; i
++)
2338 w
= SCM_VELTS (exp
)[i
];
2339 for (j
= SCM_LONG_BIT
; j
; j
--)
2341 scm_putc (w
& 1 ? '1' : '0', port
);
2345 j
= SCM_LENGTH (exp
) % SCM_LONG_BIT
;
2348 w
= SCM_VELTS (exp
)[SCM_LENGTH (exp
) / SCM_LONG_BIT
];
2351 scm_putc (w
& 1 ? '1' : '0', port
);
2358 scm_putc ('b', port
);
2360 case scm_tc7_string
:
2361 scm_putc ('a', port
);
2363 case scm_tc7_byvect
:
2364 scm_putc ('y', port
);
2367 scm_putc ('u', port
);
2370 scm_putc ('e', port
);
2373 scm_putc ('h', port
);
2375 #ifdef HAVE_LONG_LONGS
2376 case scm_tc7_llvect
:
2377 scm_putc ('l', port
);
2383 scm_putc ('s', port
);
2385 #endif /*SCM_SINGLES*/
2387 scm_putc ('i', port
);
2390 scm_putc ('c', port
);
2392 #endif /*SCM_FLOATS*/
2394 scm_putc ('(', port
);
2395 rapr1 (exp
, base
, 0, port
, pstate
);
2396 scm_putc (')', port
);
2400 GUILE_PROC(scm_array_prototype
, "array-prototype", 1, 0, 0,
2403 #define FUNC_NAME s_scm_array_prototype
2406 SCM_ASRTGO (SCM_NIMP (ra
), badarg
);
2412 badarg
:SCM_WTA (1,ra
);
2414 SCM_ASRTGO (SCM_ARRAYP (ra
), badarg
);
2416 return SCM_UNSPECIFIED
;
2417 ra
= SCM_ARRAY_V (ra
);
2419 case scm_tc7_vector
:
2424 case scm_tc7_string
:
2425 return SCM_MAKICHR ('a');
2426 case scm_tc7_byvect
:
2427 return SCM_MAKICHR ('\0');
2429 return SCM_MAKINUM (1L);
2431 return SCM_MAKINUM (-1L);
2433 return SCM_CDR (scm_intern ("s", 1));
2434 #ifdef HAVE_LONG_LONGS
2435 case scm_tc7_llvect
:
2436 return SCM_CDR (scm_intern ("l", 1));
2441 return scm_makflo (1.0);
2444 return scm_makdbl (1.0 / 3.0, 0.0);
2446 return scm_makdbl (0.0, 1.0);
2456 return SCM_ARRAY_V (ptr
);
2463 scm_must_free (SCM_CHARS (ptr
));
2464 return sizeof (scm_array
) + SCM_ARRAY_NDIM (ptr
) * sizeof (scm_array_dim
);
2470 scm_tc16_array
= scm_make_smob_type_mfpe ("array", 0,
2475 scm_add_feature ("array");