diff options
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 2687 |
1 files changed, 2687 insertions, 0 deletions
diff --git a/libguile/unif.c b/libguile/unif.c new file mode 100644 index 000000000..ed0e17c5c --- /dev/null +++ b/libguile/unif.c @@ -0,0 +1,2687 @@ +/* Copyright (C) 1995,1996 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + + +#include <stdio.h> +#include "_scm.h" + + +/* The set of uniform scm_vector types is: + * Vector of: Called: + * unsigned char string + * char byvect + * boolean bvect + * signed int ivect + * unsigned int uvect + * float fvect + * double dvect + * complex double cvect + * short svect + * long_long llvect + */ + +long scm_tc16_array; + +/* + * This complicates things too much if allowed on any array. + * C code can safely call it on arrays known to be used in a single + * threaded manner. + * + * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); + */ +static char s_vector_set_length_x[] = "vector-set-length!"; + +#ifdef __STDC__ +SCM +scm_vector_set_length_x (SCM vect, SCM len) +#else +SCM +scm_vector_set_length_x (vect, len) + SCM vect; + SCM len; +#endif +{ + long l; + scm_sizet siz; + scm_sizet sz; + + l = SCM_INUM (len); + SCM_ASRTGO (SCM_NIMP (vect), badarg1); + switch (SCM_TYP7 (vect)) + { + default: + badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x); + case scm_tc7_string: + case scm_tc7_mb_string: + SCM_ASRTGO (vect != scm_nullstr, badarg1); + sz = sizeof (char); + l++; + break; + case scm_tc7_vector: + SCM_ASRTGO (vect != scm_nullvect, badarg1); + sz = sizeof (SCM); + break; +#ifdef ARRAYS + case scm_tc7_bvect: + l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + case scm_tc7_uvect: + case scm_tc7_ivect: + sz = sizeof (long); + break; + case scm_tc7_byvect: + sz = sizeof (char); + break; + + case scm_tc7_svect: + sz = sizeof (short); + break; +#ifdef LONGLONGS + case scm_tc7_llvect: + sz = sizeof (long_long); + break; +#endif + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + sz = sizeof (float); + break; +#endif + case scm_tc7_dvect: + sz = sizeof (double); + break; + case scm_tc7_cvect: + sz = 2 * sizeof (double); + break; +#endif +#endif + } + SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x); + if (!l) + l = 1L; + siz = l * sz; + if (siz != l * sz) + scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x); + SCM_REDEFER_INTS; + SCM_SETCHARS (vect, + ((char *) + scm_must_realloc (SCM_CHARS (vect), + (long) SCM_LENGTH (vect) * sz, + (long) siz, + s_vector_set_length_x))); + if (SCM_VECTORP (vect)) + { + sz = SCM_LENGTH (vect); + while (l > sz) + SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED; + } + else if (SCM_STRINGP (vect)) + SCM_CHARS (vect)[l - 1] = 0; + SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect)); + SCM_REALLOW_INTS; + return vect; +} + + +#ifdef ARRAYS + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + +#ifdef __STDC__ +SCM +scm_makflo (float x) +#else +SCM +scm_makflo (x) + float x; +#endif +{ + SCM z; + if (x == 0.0) + return scm_flo0; + SCM_NEWCELL (z); + SCM_DEFER_INTS; + SCM_CAR (z) = scm_tc_flo; + SCM_FLO (z) = x; + SCM_ALLOW_INTS; + return z; +} +#endif +#endif + +#ifdef __STDC__ +SCM +scm_make_uve (long k, SCM prot) +#else +SCM +scm_make_uve (k, prot) + long k; + SCM prot; +#endif +{ + SCM v; + long i, type; + if (SCM_BOOL_T == prot) + { + i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + type = scm_tc7_bvect; + } + else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0'))) + { + i = sizeof (char) * k; + type = scm_tc7_byvect; + } + else if (SCM_ICHRP (prot)) + { + i = sizeof (char) * k; + type = scm_tc7_string; + } + else if (SCM_INUMP (prot)) + { + i = sizeof (long) * k; + if (SCM_INUM (prot) > 0) + type = scm_tc7_uvect; + else + type = scm_tc7_ivect; + } + else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot))) + { + char s; + + s = SCM_CHARS (prot)[0]; + if (s == 's') + { + i = sizeof (short) * k; + type = scm_tc7_svect; + } +#ifdef LONGLONGS + else if (s == 'l') + { + i = sizeof (long_long) * k; + type = scm_tc7_llvect; + } +#endif + else + { + return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); + } + } + else +#ifdef SCM_FLOATS + if (SCM_IMP (prot) || !SCM_INEXP (prot)) +#endif + /* Huge non-unif vectors are NOT supported. */ + return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); /* no special scm_vector */ +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + else if (SCM_SINGP (prot)) + + { + i = sizeof (float) * k; + type = scm_tc7_fvect; + } +#endif + else if (SCM_CPLXP (prot)) + { + i = 2 * sizeof (double) * k; + type = scm_tc7_cvect; + } + else + { + i = sizeof (double) * k; + type = scm_tc7_dvect; + } +#endif + + SCM_NEWCELL (v); + SCM_DEFER_INTS; + { + char *m; + m = scm_must_malloc ((i ? i : 1L), "vector"); + SCM_SETCHARS (v, (char *) m); + } + SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type); + SCM_ALLOW_INTS; + return v; +} + +SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length); +#ifdef __STDC__ +SCM +scm_uniform_vector_length (SCM v) +#else +SCM +scm_uniform_vector_length (v) + SCM v; +#endif +{ + SCM_ASRTGO (SCM_NIMP (v), badarg1); + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length); + case scm_tc7_bvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_vector: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + return SCM_MAKINUM (SCM_LENGTH (v)); + } +} + +SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p); +#ifdef __STDC__ +SCM +scm_array_p (SCM v, SCM prot) +#else +SCM +scm_array_p (v, prot) + SCM v; + SCM prot; +#endif +{ + int nprot; + int enclosed; + nprot = SCM_UNBNDP (prot); + enclosed = 0; + if (SCM_IMP (v)) + return SCM_BOOL_F; +loop: + switch (SCM_TYP7 (v)) + { + case scm_tc7_smob: + if (!SCM_ARRAYP (v)) + return SCM_BOOL_F; + if (nprot) + return SCM_BOOL_T; + if (enclosed++) + return SCM_BOOL_F; + v = SCM_ARRAY_V (v); + goto loop; + case scm_tc7_bvect: + return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_string: + return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_byvect: + return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_uvect: + return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_ivect: + return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_svect: + return ( nprot + || (SCM_NIMP (prot) + && SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]))); +#ifdef LONGLONGS + case scm_tc7_llvect: + return ( nprot + || (SCM_NIMP (prot) + && SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]))); +#endif +# ifdef SCM_FLOATS +# ifdef SCM_SINGLES + case scm_tc7_fvect: + return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; +# endif + case scm_tc7_dvect: + return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + case scm_tc7_cvect: + return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; +# endif + case scm_tc7_vector: + return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F; + default:; + } + return SCM_BOOL_F; +} + + +SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank); +#ifdef __STDC__ +SCM +scm_array_rank (SCM ra) +#else +SCM +scm_array_rank (ra) + SCM ra; +#endif +{ + if (SCM_IMP (ra)) + return SCM_INUM0; + switch (SCM_TYP7 (ra)) + { + default: + return SCM_INUM0; + case scm_tc7_string: + case scm_tc7_vector: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_cvect: + case scm_tc7_dvect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + case scm_tc7_svect: + return SCM_MAKINUM (1L); + case scm_tc7_smob: + if (SCM_ARRAYP (ra)) + return SCM_MAKINUM (SCM_ARRAY_NDIM (ra)); + return SCM_INUM0; + } +} + + +SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions); +#ifdef __STDC__ +SCM +scm_array_dimensions (SCM ra) +#else +SCM +scm_array_dimensions (ra) + SCM ra; +#endif +{ + SCM res = SCM_EOL; + scm_sizet k; + scm_array_dim *s; + if (SCM_IMP (ra)) + return SCM_BOOL_F; + switch (SCM_TYP7 (ra)) + { + default: + return SCM_BOOL_F; + case scm_tc7_string: + case scm_tc7_vector: + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_cvect: + case scm_tc7_dvect: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL); + case scm_tc7_smob: + if (!SCM_ARRAYP (ra)) + return SCM_BOOL_F; + k = SCM_ARRAY_NDIM (ra); + s = SCM_ARRAY_DIMS (ra); + while (k--) + res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) : + SCM_MAKINUM (1 + (s[k].ubnd)) + , res); + return res; + } +} + + +static char s_bad_ind[] = "Bad scm_array index"; + +#ifdef __STDC__ +long +scm_aind (SCM ra, SCM args, char *what) +#else +long +scm_aind (ra, args, what) + SCM ra, + SCM args; + char *what; +#endif +{ + SCM ind; + register long j; + register scm_sizet pos = SCM_ARRAY_BASE (ra); + register scm_sizet k = SCM_ARRAY_NDIM (ra); + scm_array_dim *s = SCM_ARRAY_DIMS (ra); + if (SCM_INUMP (args)) + + { + SCM_ASSERT (1 == k, SCM_UNDEFINED, SCM_WNA, what); + return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); + } + while (k && SCM_NIMP (args)) + { + ind = SCM_CAR (args); + args = SCM_CDR (args); + SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); + j = SCM_INUM (ind); + SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); + pos += (j - s->lbnd) * (s->inc); + k--; + s++; + } + SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what); + return pos; +} + + +#ifdef __STDC__ +SCM +scm_make_ra (int ndim) +#else +SCM +scm_make_ra (ndim) + int ndim; +#endif +{ + SCM ra; + SCM_NEWCELL (ra); + SCM_DEFER_INTS; + SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)), + "array")); + SCM_CAR (ra) = ((long) ndim << 17) + scm_tc16_array; + SCM_ARRAY_V (ra) = scm_nullvect; + SCM_ALLOW_INTS; + return ra; +} + +static char s_bad_spec[] = "Bad scm_array dimension"; +/* Increments will still need to be set. */ + +#ifdef __STDC__ +SCM +scm_shap2ra (SCM args, char *what) +#else +SCM +scm_shap2ra (args, what) + SCM args; + char *what; +#endif +{ + scm_array_dim *s; + SCM ra, spec, sp; + int ndim = scm_ilength (args); + SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); + ra = scm_make_ra (ndim); + SCM_ARRAY_BASE (ra) = 0; + s = SCM_ARRAY_DIMS (ra); + for (; SCM_NIMP (args); s++, args = SCM_CDR (args)) + { + spec = SCM_CAR (args); + if (SCM_IMP (spec)) + + { + SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what); + s->lbnd = 0; + s->ubnd = SCM_INUM (spec) - 1; + s->inc = 1; + } + else + { + SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what); + s->lbnd = SCM_INUM (SCM_CAR (spec)); + sp = SCM_CDR (spec); + SCM_ASSERT (SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), + spec, s_bad_spec, what); + s->ubnd = SCM_INUM (SCM_CAR (sp)); + s->inc = 1; + } + } + return ra; +} + +SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array); +#ifdef __STDC__ +SCM +scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill) +#else +SCM +scm_dimensions_to_uniform_array (dims, prot, fill) + SCM dims; + SCM prot; + SCM fill; +#endif +{ + scm_sizet k, vlen = 1; + long rlen = 1; + scm_array_dim *s; + SCM ra; + if (SCM_INUMP (dims)) + if (SCM_INUM (dims) < SCM_LENGTH_MAX) + { + SCM answer; + answer = scm_make_uve (SCM_INUM (dims), prot); + if (SCM_NNULLP (fill)) + { + SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array); + scm_array_fill_x (answer, SCM_CAR (fill)); + } + else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) + scm_array_fill_x (answer, SCM_MAKINUM (0)); + else + scm_array_fill_x (answer, prot); + return answer; + } + else + dims = scm_cons (dims, SCM_EOL); + SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)), + dims, SCM_ARG1, s_dimensions_to_uniform_array); + ra = scm_shap2ra (dims, s_dimensions_to_uniform_array); + SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS; + s = SCM_ARRAY_DIMS (ra); + k = SCM_ARRAY_NDIM (ra); + while (k--) + { + s[k].inc = (rlen > 0 ? rlen : 0); + rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; + vlen *= (s[k].ubnd - s[k].lbnd + 1); + } + if (rlen < SCM_LENGTH_MAX) + SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot); + else + { + scm_sizet bit; + switch (SCM_TYP7 (scm_make_uve (0L, prot))) + { + default: + bit = SCM_LONG_BIT; + break; + case scm_tc7_bvect: + bit = 1; + break; + case scm_tc7_string: + bit = SCM_CHAR_BIT; + break; + case scm_tc7_fvect: + bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char); + break; + case scm_tc7_dvect: + bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char); + break; + case scm_tc7_cvect: + bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char); + break; + } + SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit; + rlen += SCM_ARRAY_BASE (ra); + SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); + *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen; + } + if (SCM_NNULLP (fill)) + { + SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array); + scm_array_fill_x (ra, SCM_CAR (fill)); + } + else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) + scm_array_fill_x (ra, SCM_MAKINUM (0)); + else + scm_array_fill_x (ra, prot); + if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) + if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) + return SCM_ARRAY_V (ra); + return ra; +} + +#ifdef __STDC__ +void +scm_ra_set_contp (SCM ra) +#else +void +scm_ra_set_contp (ra) + SCM ra; +#endif +{ + scm_sizet k = SCM_ARRAY_NDIM (ra); + long inc; + if (k) + inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; + while (k--) + { + if (inc != SCM_ARRAY_DIMS (ra)[k].inc) + { + SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS; + return; + } + inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); + } + SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS; +} + + +SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); +#ifdef __STDC__ +SCM +scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims) +#else +SCM +scm_make_shared_array (oldra, mapfunc, dims) + SCM oldra; + SCM mapfunc; + SCM dims; +#endif +{ + SCM ra; + SCM inds, indptr; + SCM imap; + scm_sizet i, k; + long old_min, new_min, old_max, new_max; + scm_array_dim *s; + SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array); + SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array); + ra = scm_shap2ra (dims, s_make_shared_array); + if (SCM_ARRAYP (oldra)) + { + SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra); + old_min = old_max = SCM_ARRAY_BASE (oldra); + s = SCM_ARRAY_DIMS (oldra); + k = SCM_ARRAY_NDIM (oldra); + while (k--) + { + if (s[k].inc > 0) + old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + } + else + { + SCM_ARRAY_V (ra) = oldra; + old_min = 0; + old_max = (long) SCM_LENGTH (oldra) - 1; + } + inds = SCM_EOL; + s = SCM_ARRAY_DIMS (ra); + for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) + { + inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds); + if (s[k].ubnd < s[k].lbnd) + { + if (1 == SCM_ARRAY_NDIM (ra)) + ra = scm_make_uve (0L, scm_array_prototype (ra)); + else + SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra)); + return ra; + } + } + imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL); + if (SCM_ARRAYP (oldra)) + i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array); + else + { + if (SCM_NINUMP (imap)) + + { + SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), + imap, s_bad_ind, s_make_shared_array); + imap = SCM_CAR (imap); + } + i = SCM_INUM (imap); + } + SCM_ARRAY_BASE (ra) = new_min = new_max = i; + indptr = inds; + k = SCM_ARRAY_NDIM (ra); + while (k--) + { + if (s[k].ubnd > s[k].lbnd) + { + SCM_CAR (indptr) = SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1); + imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); + if (SCM_ARRAYP (oldra)) + + s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i; + else + { + if (SCM_NINUMP (imap)) + + { + SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), + imap, s_bad_ind, s_make_shared_array); + imap = SCM_CAR (imap); + } + s[k].inc = (long) SCM_INUM (imap) - i; + } + i += s[k].inc; + if (s[k].inc > 0) + new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + else + s[k].inc = new_max - new_min + 1; /* contiguous by default */ + indptr = SCM_CDR (indptr); + } + SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, + "mapping out of range", s_make_shared_array); + if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) + { + if (1 == s->inc && 0 == s->lbnd + && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) + return SCM_ARRAY_V (ra); + if (s->ubnd < s->lbnd) + return scm_make_uve (0L, scm_array_prototype (ra)); + } + scm_ra_set_contp (ra); + return ra; +} + + +/* args are RA . DIMS */ +SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array); +#ifdef __STDC__ +SCM +scm_transpose_array (SCM args) +#else +SCM +scm_transpose_array (args) + SCM args; +#endif +{ + SCM ra, res, vargs, *ve = &vargs; + scm_array_dim *s, *r; + int ndim, i, k; + SCM_ASSERT (SCM_NIMP (args), SCM_UNDEFINED, SCM_WNA, s_transpose_array); + ra = SCM_CAR (args); + args = SCM_CDR (args); + switch SCM_TYP7 + (ra) + { + default: + badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array); + case scm_tc7_bvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), SCM_UNDEFINED, SCM_WNA, s_transpose_array); + SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_ARG1, s_transpose_array); + return ra; + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (ra), badarg); + vargs = scm_vector (args); + SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_UNDEFINED, SCM_WNA, s_transpose_array); + ve = SCM_VELTS (vargs); + ndim = 0; + for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) + { + i = SCM_INUM (ve[k]); + SCM_ASSERT (SCM_INUMP (ve[k]) && i >= 0 && i < SCM_ARRAY_NDIM (ra), + ve[k], SCM_ARG2, s_transpose_array); + if (ndim < i) + ndim = i; + } + ndim++; + res = scm_make_ra (ndim); + SCM_ARRAY_V (res) = SCM_ARRAY_V (ra); + SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra); + for (k = ndim; k--;) + { + SCM_ARRAY_DIMS (res)[k].lbnd = 0; + SCM_ARRAY_DIMS (res)[k].ubnd = -1; + } + for (k = SCM_ARRAY_NDIM (ra); k--;) + { + i = SCM_INUM (ve[k]); + s = &(SCM_ARRAY_DIMS (ra)[k]); + r = &(SCM_ARRAY_DIMS (res)[i]); + if (r->ubnd < r->lbnd) + { + r->lbnd = s->lbnd; + r->ubnd = s->ubnd; + r->inc = s->inc; + ndim--; + } + else + { + if (r->ubnd > s->ubnd) + r->ubnd = s->ubnd; + if (r->lbnd < s->lbnd) + { + SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; + r->lbnd = s->lbnd; + } + r->inc += s->inc; + } + } + SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array); + scm_ra_set_contp (res); + return res; + } +} + +/* args are RA . AXES */ +SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array); +#ifdef __STDC__ +SCM +scm_enclose_array (SCM axes) +#else +SCM +scm_enclose_array (axes) + SCM axes; +#endif +{ + SCM axv, ra, res, ra_inr; + scm_array_dim vdim, *s = &vdim; + int ndim, j, k, ninr, noutr; + SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array); + ra = SCM_CAR (axes); + axes = SCM_CDR (axes); + if (SCM_NULLP (axes)) + + axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); + ninr = scm_ilength (axes); + ra_inr = scm_make_ra (ninr); + SCM_ASRTGO (SCM_NIMP (ra), badarg1); + switch SCM_TYP7 + (ra) + { + default: + badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array); + case scm_tc7_string: + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_vector: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + s->lbnd = 0; + s->ubnd = SCM_LENGTH (ra) - 1; + s->inc = 1; + SCM_ARRAY_V (ra_inr) = ra; + SCM_ARRAY_BASE (ra_inr) = 0; + ndim = 1; + break; + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (ra), badarg1); + s = SCM_ARRAY_DIMS (ra); + SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra); + SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra); + ndim = SCM_ARRAY_NDIM (ra); + break; + } + noutr = ndim - ninr; + axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); + SCM_ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, SCM_WNA, s_enclose_array); + res = scm_make_ra (noutr); + SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); + SCM_ARRAY_V (res) = ra_inr; + for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) + { + SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array); + j = SCM_INUM (SCM_CAR (axes)); + SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; + SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; + SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; + SCM_CHARS (axv)[j] = 1; + } + for (j = 0, k = 0; k < noutr; k++, j++) + { + while (SCM_CHARS (axv)[j]) + j++; + SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; + SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; + SCM_ARRAY_DIMS (res)[k].inc = s[j].inc; + } + scm_ra_set_contp (ra_inr); + scm_ra_set_contp (res); + return res; +} + + + +SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p); +#ifdef __STDC__ +SCM +scm_array_in_bounds_p (SCM args) +#else +SCM +scm_array_in_bounds_p (args) + SCM args; +#endif +{ + SCM v, ind = SCM_EOL; + long pos = 0; + register scm_sizet k; + register long j; + scm_array_dim *s; + SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p); + v = SCM_CAR (args); + args = SCM_CDR (args); + SCM_ASRTGO (SCM_NIMP (v), badarg1); + if (SCM_NIMP (args)) + + { + ind = SCM_CAR (args); + args = SCM_CDR (args); + SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p); + pos = SCM_INUM (ind); + } +tail: + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); + wna:scm_wta (args, (char *) SCM_WNA, s_array_in_bounds_p); + case scm_tc7_smob: + k = SCM_ARRAY_NDIM (v); + s = SCM_ARRAY_DIMS (v); + pos = SCM_ARRAY_BASE (v); + if (!k) + { + SCM_ASRTGO (SCM_NULLP (ind), wna); + ind = SCM_INUM0; + } + else + while (!0) + { + j = SCM_INUM (ind); + if (!(j >= (s->lbnd) && j <= (s->ubnd))) + { + SCM_ASRTGO (--k == scm_ilength (args), wna); + return SCM_BOOL_F; + } + pos += (j - s->lbnd) * (s->inc); + if (!(--k && SCM_NIMP (args))) + break; + ind = SCM_CAR (args); + args = SCM_CDR (args); + s++; + SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p); + } + SCM_ASRTGO (0 == k, wna); + v = SCM_ARRAY_V (v); + goto tail; + case scm_tc7_bvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + case scm_tc7_vector: + SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); + return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F; + } +} + + +SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); +SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref); +#ifdef __STDC__ +SCM +scm_uniform_vector_ref (SCM v, SCM args) +#else +SCM +scm_uniform_vector_ref (v, args) + SCM v; + SCM args; +#endif +{ + long pos; + if (SCM_IMP (v)) + + { + SCM_ASRTGO (SCM_NULLP (args), badarg); + return v; + } + else if (SCM_ARRAYP (v)) + + { + pos = scm_aind (v, args, s_uniform_vector_ref); + v = SCM_ARRAY_V (v); + } + else + { + if (SCM_NIMP (args)) + + { + SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref); + pos = SCM_INUM (SCM_CAR (args)); + SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); + } + else + { + SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref); + pos = SCM_INUM (args); + } + SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); + } + switch SCM_TYP7 + (v) + { + default: + if (SCM_NULLP (args)) + return v; + badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); + outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_uniform_vector_ref); + wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_uniform_vector_ref); + case scm_tc7_smob: + { /* enclosed */ + int k = SCM_ARRAY_NDIM (v); + SCM res = scm_make_ra (k); + SCM_ARRAY_V (res) = SCM_ARRAY_V (v); + SCM_ARRAY_BASE (res) = pos; + while (k--) + { + SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; + SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; + SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; + } + return res; + } + case scm_tc7_bvect: + if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + return SCM_BOOL_T; + else + return SCM_BOOL_F; + case scm_tc7_string: + return SCM_MAKICHR (SCM_CHARS (v)[pos]); + case scm_tc7_byvect: + return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); +# ifdef SCM_INUMS_ONLY + case scm_tc7_uvect: + case scm_tc7_ivect: + return SCM_MAKINUM (SCM_VELTS (v)[pos]); +# else + case scm_tc7_uvect: + return scm_ulong2num(SCM_VELTS(v)[pos]); + case scm_tc7_ivect: + return scm_long2num(SCM_VELTS(v)[pos]); +# endif + + case scm_tc7_svect: + return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); +#ifdef LONGLONGS + case scm_tc7_llvect: + return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); +#endif + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + return scm_makflo (((float *) SCM_CDR (v))[pos]); +#endif + case scm_tc7_dvect: + return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); + case scm_tc7_cvect: + return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], + ((double *) SCM_CDR (v))[2 * pos + 1]); +#endif + case scm_tc7_vector: + return SCM_VELTS (v)[pos]; + } +} + +/* Internal version of scm_uniform_vector_ref for uves that does no error checking and + tries to recycle conses. (Make *sure* you want them recycled.) */ +#ifdef __STDC__ +SCM +scm_cvref (SCM v, scm_sizet pos, SCM last) +#else +SCM +scm_cvref (v, pos, last) + SCM v; + scm_sizet pos; + SCM last; +#endif +{ + switch SCM_TYP7 + (v) + { + default: + scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); + case scm_tc7_bvect: + if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + return SCM_BOOL_T; + else + return SCM_BOOL_F; + case scm_tc7_string: + return SCM_MAKICHR (SCM_CHARS (v)[pos]); + case scm_tc7_byvect: + return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); +# ifdef SCM_INUMS_ONLY + case scm_tc7_uvect: + case scm_tc7_ivect: + return SCM_MAKINUM (SCM_VELTS (v)[pos]); +# else + case scm_tc7_uvect: + return scm_ulong2num(SCM_VELTS(v)[pos]); + case scm_tc7_ivect: + return scm_long2num(SCM_VELTS(v)[pos]); +# endif + case scm_tc7_svect: + return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); +#ifdef LONGLONGS + case scm_tc7_llvect: + return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); +#endif +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) + { + SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; + return last; + } + return scm_makflo (((float *) SCM_CDR (v))[pos]); +#endif + case scm_tc7_dvect: +#ifdef SCM_SINGLES + if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) +#else + if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) +#endif + { + SCM_REAL (last) = ((double *) SCM_CDR (v))[pos]; + return last; + } + return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); + case scm_tc7_cvect: + if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) + { + SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; + SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; + return last; + } + return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], + ((double *) SCM_CDR (v))[2 * pos + 1]); +#endif + case scm_tc7_vector: + return SCM_VELTS (v)[pos]; + case scm_tc7_smob: + { /* enclosed scm_array */ + int k = SCM_ARRAY_NDIM (v); + SCM res = scm_make_ra (k); + SCM_ARRAY_V (res) = SCM_ARRAY_V (v); + SCM_ARRAY_BASE (res) = pos; + while (k--) + { + SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; + SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; + SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; + } + return res; + } + } +} + +SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); +SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x); +#ifdef __STDC__ +SCM +scm_array_set_x (SCM v, SCM obj, SCM args) +#else +SCM +scm_array_set_x (v, obj, args) + SCM v; + SCM obj; + SCM args; +#endif +{ + long pos; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + if (SCM_ARRAYP (v)) + + { + pos = scm_aind (v, args, s_array_set_x); + v = SCM_ARRAY_V (v); + } + else + { + if (SCM_NIMP (args)) + + { + SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x); + pos = SCM_INUM (SCM_CAR (args)); + SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); + } + else + { + SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x); + pos = SCM_INUM (args); + } + SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); + } + switch (SCM_TYP7 (v)) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x); + outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_array_set_x); + wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_array_set_x); + case scm_tc7_smob: /* enclosed */ + goto badarg1; + case scm_tc7_bvect: + if (SCM_BOOL_F == obj) + SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); + else if (SCM_BOOL_T == obj) + SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); + else + badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x); + break; + case scm_tc7_string: + SCM_ASRTGO (SCM_ICHRP (obj), badarg3); + SCM_CHARS (v)[pos] = SCM_ICHR (obj); + break; + case scm_tc7_byvect: + if (SCM_ICHRP (obj)) + obj = SCM_MAKINUM (SCM_ICHR (obj)); + SCM_ASRTGO (SCM_INUMP (obj), badarg3); + ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); + break; +# ifdef SCM_INUMS_ONLY + case scm_tc7_uvect: + SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3); + case scm_tc7_ivect: + SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; +# else + case scm_tc7_uvect: + SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break; + case scm_tc7_ivect: + SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break; +# endif + break; + + case scm_tc7_svect: + SCM_ASRTGO (SCM_INUMP (obj), badarg3); + ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); + break; +#ifdef LONGLONGS + case scm_tc7_llvect: + ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x); + break; +#endif + + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); + ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj); + break; +#endif + case scm_tc7_dvect: + SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); + ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj); + break; + case scm_tc7_cvect: + SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3); + ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); + ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; + break; +#endif + case scm_tc7_vector: + SCM_VELTS (v)[pos] = obj; + break; + } + return SCM_UNSPECIFIED; +} + +SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents); +#ifdef __STDC__ +SCM +scm_array_contents (SCM ra, SCM strict) +#else +SCM +scm_array_contents (ra, strict) + SCM ra; + SCM strict; +#endif +{ + SCM sra; + if (SCM_IMP (ra)) + return SCM_BOOL_F; + switch SCM_TYP7 + (ra) + { + default: + return SCM_BOOL_F; + case scm_tc7_vector: + case scm_tc7_string: + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_svect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + return ra; + case scm_tc7_smob: + { + scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1; + if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra)) + return SCM_BOOL_F; + for (k = 0; k < ndim; k++) + len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; + if (!SCM_UNBNDP (strict)) + { + if SCM_ARRAY_BASE + (ra) return SCM_BOOL_F; + if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc)) + return SCM_BOOL_F; + if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) + { + if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) || + SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || + len % SCM_LONG_BIT) + return SCM_BOOL_F; + } + } + if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) + return SCM_ARRAY_V (ra); + sra = scm_make_ra (1); + SCM_ARRAY_DIMS (sra)->lbnd = 0; + SCM_ARRAY_DIMS (sra)->ubnd = len - 1; + SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra); + SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra); + SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1); + return sra; + } + } +} + +#ifdef __STDC__ +SCM +scm_ra2contig (SCM ra, int copy) +#else +SCM +scm_ra2contig (ra, copy) + SCM ra; + int copy; +#endif +{ + SCM ret; + long inc = 1; + scm_sizet k, len = 1; + for (k = SCM_ARRAY_NDIM (ra); k--;) + len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; + k = SCM_ARRAY_NDIM (ra); + if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc))) + { + if (scm_tc7_bvect != SCM_TYP7 (ra)) + return ra; + if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) && + 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && + 0 == len % SCM_LONG_BIT)) + return ra; + } + ret = scm_make_ra (k); + SCM_ARRAY_BASE (ret) = 0; + while (k--) + { + SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd; + SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd; + SCM_ARRAY_DIMS (ret)[k].inc = inc; + inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; + } + SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra)); + if (copy) + scm_array_copy_x (ra, ret); + return ret; +} + + + +SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x); +#ifdef __STDC__ +SCM +scm_uniform_array_read_x (SCM ra, SCM port) +#else +SCM +scm_uniform_array_read_x (ra, port) + SCM ra; + SCM port; +#endif +{ + SCM cra, v = ra; + long sz, len, ans; + long start = 0; + if (SCM_UNBNDP (port)) + port = scm_cur_inp; + else + SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, s_uniform_array_read_x); + SCM_ASRTGO (SCM_NIMP (v), badarg1); + len = SCM_LENGTH (v); +loop: + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (v), badarg1); + cra = scm_ra2contig (ra, 0); + start = SCM_ARRAY_BASE (cra); + len = SCM_ARRAY_DIMS (cra)->inc * + (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); + v = SCM_ARRAY_V (cra); + goto loop; + case scm_tc7_string: + case scm_tc7_byvect: + sz = sizeof (char); + break; + case scm_tc7_bvect: + len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + start /= SCM_LONG_BIT; + case scm_tc7_uvect: + case scm_tc7_ivect: + sz = sizeof (long); + break; + case scm_tc7_svect: + sz = sizeof (short); + break; +#ifdef LONGLONGS + case scm_tc7_llvect: + sz = sizeof (long_long); + break; +#endif +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + sz = sizeof (float); + break; +#endif + case scm_tc7_dvect: + sz = sizeof (double); + break; + case scm_tc7_cvect: + sz = 2 * sizeof (double); + break; +#endif + } + /* An ungetc before an fread will not work on some systems if setbuf(0). + do #define NOSETBUF in scmfig.h to fix this. */ + if (SCM_CRDYP (port)) + + { /* UGGH!!! */ + ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port)); + SCM_CLRDY (port); /* Clear ungetted char */ + } + SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); + if (SCM_TYP7 (v) == scm_tc7_bvect) + ans *= SCM_LONG_BIT; + if (v != ra && cra != ra) + scm_array_copy_x (cra, ra); + return SCM_MAKINUM (ans); +} + +SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write); +#ifdef __STDC__ +SCM +scm_uniform_array_write (SCM v, SCM port) +#else +SCM +scm_uniform_array_write (v, port) + SCM v; + SCM port; +#endif +{ + long sz, len, ans; + long start = 0; + if (SCM_UNBNDP (port)) + port = scm_cur_outp; + else + SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write); + SCM_ASRTGO (SCM_NIMP (v), badarg1); + len = SCM_LENGTH (v); +loop: + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (v), badarg1); + v = scm_ra2contig (v, 1); + start = SCM_ARRAY_BASE (v); + len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1); + v = SCM_ARRAY_V (v); + goto loop; + case scm_tc7_byvect: + case scm_tc7_string: + sz = sizeof (char); + break; + case scm_tc7_bvect: + len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + start /= SCM_LONG_BIT; + case scm_tc7_uvect: + case scm_tc7_ivect: + sz = sizeof (long); + break; + case scm_tc7_svect: + sz = sizeof (short); + break; +#ifdef LONGLONGS + case scm_tc7_llvect: + sz = sizeof (long_long); + break; +#endif +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + sz = sizeof (float); + break; +#endif + case scm_tc7_dvect: + sz = sizeof (double); + break; + case scm_tc7_cvect: + sz = 2 * sizeof (double); + break; +#endif + } + SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); + if (SCM_TYP7 (v) == scm_tc7_bvect) + ans *= SCM_LONG_BIT; + return SCM_MAKINUM (ans); +} + + +static char cnt_tab[16] = +{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; + +SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count); +#ifdef __STDC__ +SCM +scm_bit_count (SCM item, SCM seq) +#else +SCM +scm_bit_count (item, seq) + SCM item; + SCM seq; +#endif +{ + long i; + register unsigned long cnt = 0, w; + SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count); + switch SCM_TYP7 + (seq) + { + default: + scm_wta (seq, (char *) SCM_ARG2, s_bit_count); + case scm_tc7_bvect: + if (0 == SCM_LENGTH (seq)) + return SCM_INUM0; + i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; + w = SCM_VELTS (seq)[i]; + if (SCM_FALSEP (item)) + w = ~w; + w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); + while (!0) + { + for (; w; w >>= 4) + cnt += cnt_tab[w & 0x0f]; + if (0 == i--) + return SCM_MAKINUM (cnt); + w = SCM_VELTS (seq)[i]; + if (SCM_FALSEP (item)) + w = ~w; + } + } +} + + +SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position); +#ifdef __STDC__ +SCM +scm_bit_position (SCM item, SCM v, SCM k) +#else +SCM +scm_bit_position (item, v, k) + SCM item; + SCM v; + SCM k; +#endif +{ + long i, lenw, xbits, pos = SCM_INUM (k); + register unsigned long w; + SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position); + SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position); + SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), + k, SCM_OUTOFRANGE, s_bit_position); + if (pos == SCM_LENGTH (v)) + return SCM_BOOL_F; + switch SCM_TYP7 + (v) + { + default: + scm_wta (v, (char *) SCM_ARG2, s_bit_position); + case scm_tc7_bvect: + if (0 == SCM_LENGTH (v)) + return SCM_MAKINUM (-1L); + lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ + i = pos / SCM_LONG_BIT; + w = SCM_VELTS (v)[i]; + if (SCM_FALSEP (item)) + w = ~w; + xbits = (pos % SCM_LONG_BIT); + pos -= xbits; + w = ((w >> xbits) << xbits); + xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT; + while (!0) + { + if (w && (i == lenw)) + w = ((w << xbits) >> xbits); + if (w) + while (w) + switch (w & 0x0f) + { + default: + return SCM_MAKINUM (pos); + case 2: + case 6: + case 10: + case 14: + return SCM_MAKINUM (pos + 1); + case 4: + case 12: + return SCM_MAKINUM (pos + 2); + case 8: + return SCM_MAKINUM (pos + 3); + case 0: + pos += 4; + w >>= 4; + } + if (++i > lenw) + break; + pos += SCM_LONG_BIT; + w = SCM_VELTS (v)[i]; + if (SCM_FALSEP (item)) + w = ~w; + } + return SCM_BOOL_F; + } +} + + +SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x); +#ifdef __STDC__ +SCM +scm_bit_set_star_x (SCM v, SCM kv, SCM obj) +#else +SCM +scm_bit_set_star_x (v, kv, obj) + SCM v; + SCM kv; + SCM obj; +#endif +{ + register long i, k, vlen; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + SCM_ASRTGO (SCM_NIMP (kv), badarg2); + switch SCM_TYP7 + (kv) + { + default: + badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x); + case scm_tc7_uvect: + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x); + case scm_tc7_bvect: + vlen = SCM_LENGTH (v); + if (SCM_BOOL_F == obj) + for (i = SCM_LENGTH (kv); i;) + { + k = SCM_VELTS (kv)[--i]; + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); + SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); + } + else if (SCM_BOOL_T == obj) + for (i = SCM_LENGTH (kv); i;) + { + k = SCM_VELTS (kv)[--i]; + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); + SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); + } + else + badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x); + } + break; + case scm_tc7_bvect: + SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); + if (SCM_BOOL_F == obj) + for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); + else if (SCM_BOOL_T == obj) + for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k]; + else + goto badarg3; + break; + } + return SCM_UNSPECIFIED; +} + + +SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star); +#ifdef __STDC__ +SCM +scm_bit_count_star (SCM v, SCM kv, SCM obj) +#else +SCM +scm_bit_count_star (v, kv, obj) + SCM v; + SCM kv; + SCM obj; +#endif +{ + register long i, vlen, count = 0; + register unsigned long k; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + SCM_ASRTGO (SCM_NIMP (kv), badarg2); + switch SCM_TYP7 + (kv) + { + default: + badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star); + case scm_tc7_uvect: + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star); + case scm_tc7_bvect: + vlen = SCM_LENGTH (v); + if (SCM_BOOL_F == obj) + for (i = SCM_LENGTH (kv); i;) + { + k = SCM_VELTS (kv)[--i]; + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); + if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) + count++; + } + else if (SCM_BOOL_T == obj) + for (i = SCM_LENGTH (kv); i;) + { + k = SCM_VELTS (kv)[--i]; + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); + if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) + count++; + } + else + badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star); + } + break; + case scm_tc7_bvect: + SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); + if (0 == SCM_LENGTH (v)) + return SCM_INUM0; + SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); + obj = (SCM_BOOL_T == obj); + i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; + k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); + while (!0) + { + for (; k; k >>= 4) + count += cnt_tab[k & 0x0f]; + if (0 == i--) + return SCM_MAKINUM (count); + k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + } + } + return SCM_MAKINUM (count); +} + + +SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x); +#ifdef __STDC__ +SCM +scm_bit_invert_x (SCM v) +#else +SCM +scm_bit_invert_x (v) + SCM v; +#endif +{ + register long k; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + k = SCM_LENGTH (v); + switch SCM_TYP7 + (v) + { + case scm_tc7_bvect: + for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) + SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; + break; + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x); + } + return SCM_UNSPECIFIED; +} + + +SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); +#ifdef __STDC__ +SCM +scm_string_upcase_x (SCM v) +#else +SCM +scm_string_upcase_x (v) + SCM v; +#endif +{ + register long k; + register unsigned char *cs; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + k = SCM_LENGTH (v); + switch SCM_TYP7 + (v) + { + case scm_tc7_string: + cs = SCM_UCHARS (v); + while (k--) + cs[k] = scm_upcase(cs[k]); + break; + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); + } + return v; +} + +SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); +#ifdef __STDC__ +SCM +scm_string_downcase_x (SCM v) +#else +SCM +scm_string_downcase_x (v) + SCM v; +#endif +{ + register long k; + register unsigned char *cs; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + k = SCM_LENGTH (v); + switch SCM_TYP7 + (v) + { + case scm_tc7_string: + cs = SCM_UCHARS (v); + while (k--) + cs[k] = scm_downcase(cs[k]); + break; + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); + } + return v; +} + + +#ifdef __STDC__ +SCM +scm_istr2bve (char *str, long len) +#else +SCM +scm_istr2bve (str, len) + char *str; + long len; +#endif +{ + SCM v = scm_make_uve (len, SCM_BOOL_T); + long *data = (long *) SCM_VELTS (v); + register unsigned long mask; + register long k; + register long j; + for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) + { + data[k] = 0L; + j = len - k * SCM_LONG_BIT; + if (j > SCM_LONG_BIT) + j = SCM_LONG_BIT; + for (mask = 1L; j--; mask <<= 1) + switch (*str++) + { + case '0': + break; + case '1': + data[k] |= mask; + break; + default: + return SCM_BOOL_F; + } + } + return v; +} + + +#ifdef __STDC__ +static SCM +ra2l (SCM ra, scm_sizet base, scm_sizet k) +#else +static SCM +ra2l (ra, base, k) + SCM ra; + scm_sizet base; + scm_sizet k; +#endif +{ + register SCM res = SCM_EOL; + register long inc = SCM_ARRAY_DIMS (ra)[k].inc; + register scm_sizet i; + if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) + return SCM_EOL; + i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; + if (k < SCM_ARRAY_NDIM (ra) - 1) + { + do + { + i -= inc; + res = scm_cons (ra2l (ra, i, k + 1), res); + } + while (i != base); + } + else + do + { + i -= inc; + res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res); + } + while (i != base); + return res; +} + + +SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list); +#ifdef __STDC__ +SCM +scm_array_to_list (SCM v) +#else +SCM +scm_array_to_list (v) + SCM v; +#endif +{ + SCM res = SCM_EOL; + register long k; + SCM_ASRTGO (SCM_NIMP (v), badarg1); + switch SCM_TYP7 + (v) + { + default: + badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (v), badarg1); + return ra2l (v, SCM_ARRAY_BASE (v), 0); + case scm_tc7_vector: + return scm_vector_to_list (v); + case scm_tc7_string: + return scm_string_to_list (v); + case scm_tc7_bvect: + { + long *data = (long *) SCM_VELTS (v); + register unsigned long mask; + for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) + for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1) + res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); + for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) + res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); + return res; + } +# ifdef SCM_INUMS_ONLY + case scm_tc7_uvect: + case scm_tc7_ivect: + { + long *data = (long *) SCM_VELTS (v); + for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + res = scm_cons (SCM_MAKINUM (data[k]), res); + return res; + } +# else + case scm_tc7_uvect: { + long *data = (long *)SCM_VELTS(v); + for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_ulong2num(data[k]), res); + return res; + } + case scm_tc7_ivect: { + long *data = (long *)SCM_VELTS(v); + for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_long2num(data[k]), res); + return res; + } +# endif + case scm_tc7_svect: { + short *data; + data = (short *)SCM_VELTS(v); + for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(SCM_MAKINUM (data[k]), res); + return res; + } +#ifdef LONGLONGS + case scm_tc7_llvect: { + long_long *data; + data = (long_long *)SCM_VELTS(v); + for (k = SCM_LENGTH(v) - 1; k >= 0; k--) + res = scm_cons(scm_long_long2num(data[k]), res); + return res; + } +#endif + + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + { + float *data = (float *) SCM_VELTS (v); + for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + res = scm_cons (scm_makflo (data[k]), res); + return res; + } +#endif /*SCM_SINGLES*/ + case scm_tc7_dvect: + { + double *data = (double *) SCM_VELTS (v); + for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + res = scm_cons (scm_makdbl (data[k], 0.0), res); + return res; + } + case scm_tc7_cvect: + { + double (*data)[2] = (double (*)[2]) SCM_VELTS (v); + for (k = SCM_LENGTH (v) - 1; k >= 0; k--) + res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); + return res; + } +#endif /*SCM_FLOATS*/ + } +} + + +static char s_bad_ralst[] = "Bad scm_array contents scm_list"; +static int l2ra (); + +SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array); +#ifdef __STDC__ +SCM +scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst) +#else +SCM +scm_list_to_uniform_array (ndim, prot, lst) + SCM ndim; + SCM prot; + SCM lst; +#endif +{ + SCM shp = SCM_EOL; + SCM row = lst; + SCM ra; + scm_sizet k; + long n; + SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array); + k = SCM_INUM (ndim); + while (k--) + { + n = scm_ilength (row); + SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array); + shp = scm_cons (SCM_MAKINUM (n), shp); + if (SCM_NIMP (row)) + row = SCM_CAR (row); + } + ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL); + if (SCM_NULLP (shp)) + + { + SCM_ASRTGO (1 == scm_ilength (lst), badlst); + scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL); + return ra; + } + if (!SCM_ARRAYP (ra)) + { + for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst)) + scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); + return ra; + } + if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) + return ra; + else + badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array); + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +static int +l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) +#else +static int +l2ra (lst, ra, base, k) + SCM lst; + SCM ra; + scm_sizet base; + scm_sizet k; +#endif +{ + register long inc = SCM_ARRAY_DIMS (ra)[k].inc; + register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); + int ok = 1; + if (n <= 0) + return (SCM_EOL == lst); + if (k < SCM_ARRAY_NDIM (ra) - 1) + { + while (n--) + { + if (SCM_IMP (lst) || SCM_NCONSP (lst)) + return 0; + ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1); + base += inc; + lst = SCM_CDR (lst); + } + if (SCM_NNULLP (lst)) + return 0; + } + else + { + while (n--) + { + if (SCM_IMP (lst) || SCM_NCONSP (lst)) + return 0; + ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base)); + base += inc; + lst = SCM_CDR (lst); + } + if (SCM_NNULLP (lst)) + return 0; + } + return ok; +} + +#ifdef __STDC__ +static void +rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing) +#else +static void +rapr1 (ra, j, k, port, writing) + SCM ra; + scm_sizet j; + scm_sizet k; + SCM port; + int writing; +#endif +{ + long inc = 1; + long n = SCM_LENGTH (ra); + int enclosed = 0; +tail: + switch SCM_TYP7 + (ra) + { + case scm_tc7_smob: + if (enclosed++) + { + SCM_ARRAY_BASE (ra) = j; + if (n-- > 0) + scm_iprin1 (ra, port, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_ARRAY_BASE (ra) = j; + scm_iprin1 (ra, port, writing); + } + break; + } + if (k + 1 < SCM_ARRAY_NDIM (ra)) + { + long i; + inc = SCM_ARRAY_DIMS (ra)[k].inc; + for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) + { + scm_gen_putc ('(', port); + rapr1 (ra, j, k + 1, port, writing); + scm_gen_puts (scm_regular_string, ") ", port); + j += inc; + } + if (i == SCM_ARRAY_DIMS (ra)[k].ubnd) + { /* could be zero size. */ + scm_gen_putc ('(', port); + rapr1 (ra, j, k + 1, port, writing); + scm_gen_putc (')', port); + } + break; + } + if SCM_ARRAY_NDIM + (ra) + { /* Could be zero-dimensional */ + inc = SCM_ARRAY_DIMS (ra)[k].inc; + n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); + } + else + n = 1; + ra = SCM_ARRAY_V (ra); + goto tail; + default: + if (n-- > 0) + scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing); + } + break; + case scm_tc7_string: + if (n-- > 0) + scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing); + if (writing) + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing); + } + else + for (j += inc; n-- > 0; j += inc) + scm_gen_putc (SCM_CHARS (ra)[j], port); + break; + case scm_tc7_byvect: + if (n-- > 0) + scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); + } + break; + + case scm_tc7_uvect: + case scm_tc7_ivect: + if (n-- > 0) + scm_intprint (SCM_VELTS (ra)[j], 10, port); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_intprint (SCM_VELTS (ra)[j], 10, port); + } + break; + + case scm_tc7_svect: + if (n-- > 0) + scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); + } + break; + +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + if (n-- > 0) + { + SCM z = scm_makflo (1.0); + SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + } + } + break; +#endif /*SCM_SINGLES*/ + case scm_tc7_dvect: + if (n-- > 0) + { + SCM z = scm_makdbl (1.0 / 3.0, 0.0); + SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + } + } + break; + case scm_tc7_cvect: + if (n-- > 0) + { + SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0); + SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]); + SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; + scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; + SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; + scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing); + } + } + break; +#endif /*SCM_FLOATS*/ + } +} + + +#ifdef __STDC__ +int +scm_raprin1 (SCM exp, SCM port, int writing) +#else +int +scm_raprin1 (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + SCM v = exp; + scm_sizet base = 0; + scm_gen_putc ('#', port); +tail: + switch SCM_TYP7 + (v) + { + case scm_tc7_smob: + { + long ndim = SCM_ARRAY_NDIM (v); + base = SCM_ARRAY_BASE (v); + v = SCM_ARRAY_V (v); + if (SCM_ARRAYP (v)) + + { + scm_gen_puts (scm_regular_string, "<enclosed-array ", port); + rapr1 (exp, base, 0, port, writing); + scm_gen_putc ('>', port); + return 1; + } + else + { + scm_intprint (ndim, 10, port); + goto tail; + } + } + case scm_tc7_bvect: + if (exp == v) + { /* a uve, not an scm_array */ + register long i, j, w; + scm_gen_putc ('*', port); + for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) + { + w = SCM_VELTS (exp)[i]; + for (j = SCM_LONG_BIT; j; j--) + { + scm_gen_putc (w & 1 ? '1' : '0', port); + w >>= 1; + } + } + j = SCM_LENGTH (exp) % SCM_LONG_BIT; + if (j) + { + w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; + for (; j; j--) + { + scm_gen_putc (w & 1 ? '1' : '0', port); + w >>= 1; + } + } + return 1; + } + else + scm_gen_putc ('b', port); + break; + case scm_tc7_string: + scm_gen_putc ('a', port); + break; + case scm_tc7_byvect: + scm_gen_puts (scm_regular_string, "bytes", port); + break; + case scm_tc7_uvect: + scm_gen_putc ('u', port); + break; + case scm_tc7_ivect: + scm_gen_putc ('e', port); + break; + case scm_tc7_svect: + scm_gen_puts (scm_regular_string, "short", port); + break; +#ifdef LONGLONGS + case scm_tc7_llvect: + scm_gen_puts (scm_regular_string, "long_long", port); + break; +#endif +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + scm_gen_putc ('s', port); + break; +#endif /*SCM_SINGLES*/ + case scm_tc7_dvect: + scm_gen_putc ('i', port); + break; + case scm_tc7_cvect: + scm_gen_putc ('c', port); + break; +#endif /*SCM_FLOATS*/ + } + scm_gen_putc ('(', port); + rapr1 (exp, base, 0, port, writing); + scm_gen_putc (')', port); + return 1; +} + +SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); +#ifdef __STDC__ +SCM +scm_array_prototype (SCM ra) +#else +SCM +scm_array_prototype (ra) + SCM ra; +#endif +{ + int enclosed = 0; + SCM_ASRTGO (SCM_NIMP (ra), badarg); +loop: + switch SCM_TYP7 + (ra) + { + default: + badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype); + case scm_tc7_smob: + SCM_ASRTGO (SCM_ARRAYP (ra), badarg); + if (enclosed++) + return SCM_UNSPECIFIED; + ra = SCM_ARRAY_V (ra); + goto loop; + case scm_tc7_vector: + return SCM_EOL; + case scm_tc7_bvect: + return SCM_BOOL_T; + case scm_tc7_string: + return SCM_MAKICHR ('a'); + case scm_tc7_byvect: + return SCM_MAKICHR ('\0'); + case scm_tc7_uvect: + return SCM_MAKINUM (1L); + case scm_tc7_ivect: + return SCM_MAKINUM (-1L); + case scm_tc7_svect: + return SCM_CDR (scm_intern ("s", 1)); +#ifdef LONGLONGS + case scm_tc7_llvect: + return SCM_CDR (scm_intern ("l", 1)); +#endif +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + return scm_makflo (1.0); +#endif + case scm_tc7_dvect: + return scm_makdbl (1.0 / 3.0, 0.0); + case scm_tc7_cvect: + return scm_makdbl (0.0, 1.0); +#endif + } +} + +#ifdef __STDC__ +static SCM +markra (SCM ptr) +#else +static SCM +markra (ptr) + SCM ptr; +#endif +{ + if SCM_GC8MARKP + (ptr) return SCM_BOOL_F; + SCM_SETGC8MARK (ptr); + return SCM_ARRAY_V (ptr); +} + +#ifdef __STDC__ +static scm_sizet +freera (SCM ptr) +#else +static scm_sizet +freera (ptr) + SCM ptr; +#endif +{ + scm_must_free (SCM_CHARS (ptr)); + return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); +} + +static scm_smobfuns rasmob = +{markra, freera, scm_raprin1, scm_array_equal_p}; + + +/* This must be done after scm_init_scl() */ +#ifdef __STDC__ +void +scm_init_unif (void) +#else +void +scm_init_unif () +#endif +{ +#include "unif.x" + scm_tc16_array = scm_newsmob (&rasmob); + scm_add_feature ("array"); +} + +#else /* ARRAYS */ + +#ifdef __STDC__ +int +scm_raprin1 (SCM exp, SCM port, int writing) +#else +int +scm_raprin1 (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + return 0; +} + +#ifdef __STDC__ +SCM +scm_istr2bve (char *str, long len) +#else +SCM +scm_istr2bve (str, len) + char *str; + long len; +#endif +{ + return SCM_BOOL_F; +} + +#ifdef __STDC__ +SCM +scm_array_equal_p (SCM ra0, SCM ra1) +#else +SCM +scm_array_equal_p (ra0, ra1) + SCM ra0; + SCM ra1; +#endif +{ + return SCM_BOOL_F; +} + +void +scm_init_unif () +{ + scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); +} + +#endif /* ARRAYS */ + + + + |