summaryrefslogtreecommitdiff
path: root/libguile/unif.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/unif.c')
-rw-r--r--libguile/unif.c2687
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 */
+
+
+
+