-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 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
*
* 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.
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* 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.
- */
+ * If you do not wish that, delete this exception notice. */
\f
#include <stdio.h>
#include "eval.h"
#include "genio.h"
#include "smob.h"
-#include "sequences.h"
#include "strop.h"
#include "feature.h"
#include "unif.h"
#include "ramap.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
\f
/* The set of uniform scm_vector types is:
* Vector of: Called:
*/
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;
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:
+ case scm_tc7_wvect:
SCM_ASRTGO (vect != scm_nullvect, badarg1);
sz = sizeof (SCM);
break;
#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_SETCAR (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;
}
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
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_vector:
+ case scm_tc7_wvect:
case scm_tc7_svect:
#ifdef LONGLONGS
case scm_tc7_llvect:
}
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;
return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
# endif
case scm_tc7_vector:
+ case scm_tc7_wvect:
return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F;
default:;
}
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;
return SCM_INUM0;
case scm_tc7_string:
case scm_tc7_vector:
+ case scm_tc7_wvect:
case scm_tc7_byvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
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;
return SCM_BOOL_F;
case scm_tc7_string:
case scm_tc7_vector:
+ case scm_tc7_wvect:
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_uvect:
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 ra;
SCM args;
char *what;
-#endif
{
SCM ind;
register long j;
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);
+ SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
}
while (k && SCM_NIMP (args))
k--;
s++;
}
- SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what);
+ SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
+ NULL);
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_SETCAR (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;
if (SCM_IMP (spec))
{
- SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what);
+ 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);
+ 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);
+ SCM_ASSERT (SCM_NIMP (sp) && SCM_CONSP (sp)
+ && 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;
}
}
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;
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_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array),
+ SCM_WNA, NULL);
scm_array_fill_x (answer, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
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;
+ SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
s = SCM_ARRAY_DIMS (ra);
k = SCM_ARRAY_NDIM (ra);
while (k--)
}
if (SCM_NNULLP (fill))
{
- SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
+ SCM_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
+ NULL);
scm_array_fill_x (ra, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
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)
+ long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
+ while (k--)
{
- SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS;
- return;
+ if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
+ {
+ SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS);
+ return;
+ }
+ inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
+ - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
- SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
+ SCM_SETOR_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;
return ra;
}
}
- imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL);
+ imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array);
else
{
if (s[k].ubnd > s[k].lbnd)
{
- SCM_CAR (indptr) = SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1);
+ SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
/* 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);
+ SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
+ SCM_WNA, NULL);
ra = SCM_CAR (args);
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
args = SCM_CDR (args);
- switch SCM_TYP7
- (ra)
+ switch (SCM_TYP7 (ra))
{
default:
badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
#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);
+ SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
+ s_transpose_array);
+ SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
+ 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);
+ SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ ve = SCM_VELTS (vargs);
ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{
+ SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
+ s_transpose_array);
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);
+ SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k],
+ SCM_OUTOFRANGE, s_transpose_array);
if (ndim < i)
ndim = i;
}
r->inc += s->inc;
}
}
- SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array);
+ SCM_ASSERT (ndim <= 0, args, "bad argument 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);
+ SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
+ NULL);
ra = SCM_CAR (axes);
axes = SCM_CDR (axes);
if (SCM_NULLP (axes))
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_vector:
+ case scm_tc7_wvect:
case scm_tc7_svect:
#ifdef LONGLONGS
case scm_tc7_llvect:
}
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);
+ SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
+ SCM_WNA, NULL);
res = scm_make_ra (noutr);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr;
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);
+ SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
+ SCM_WNA, NULL);
v = SCM_CAR (args);
args = SCM_CDR (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
{
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);
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
case scm_tc7_smob:
k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v);
case scm_tc7_llvect:
#endif
case scm_tc7_vector:
+ case scm_tc7_wvect:
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))
+ 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);
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);
+ badarg:
+ scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
+ abort ();
+ outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
case scm_tc7_smob:
{ /* enclosed */
int k = SCM_ARRAY_NDIM (v);
((double *) SCM_CDR (v))[2 * pos + 1]);
#endif
case scm_tc7_vector:
+ case scm_tc7_wvect:
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)
((double *) SCM_CDR (v))[2 * pos + 1]);
#endif
case scm_tc7_vector:
+ case scm_tc7_wvect:
return SCM_VELTS (v)[pos];
case scm_tc7_smob:
{ /* enclosed scm_array */
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
+
+/* Note that args may be a list or an immediate object, depending which
+ PROC is used (and it's called from C too). */
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_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
+ SCM_ARG3, s_array_set_x);
SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
+ pos = SCM_INUM (SCM_CAR (args));
}
else
{
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x);
+ SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, 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);
+ default: badarg1:
+ scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
+ abort ();
+ outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
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);
+ badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x);
break;
case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (obj), badarg3);
+ SCM_ASRTGO (SCM_ICHRP (obj), badobj);
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);
+ obj = SCM_MAKINUM ((char) SCM_ICHR (obj));
+ SCM_ASRTGO (SCM_INUMP (obj), badobj);
((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
break;
# ifdef SCM_INUMS_ONLY
case scm_tc7_uvect:
- SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3);
+ SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
case scm_tc7_ivect:
- SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
+ SCM_ASRTGO(SCM_INUMP(obj), badobj); 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;
+ SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break;
case scm_tc7_ivect:
- SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break;
+ SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break;
# endif
break;
case scm_tc7_svect:
- SCM_ASRTGO (SCM_INUMP (obj), badarg3);
+ SCM_ASRTGO (SCM_INUMP (obj), badobj);
((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);
+ ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, 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);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
break;
#endif
case scm_tc7_dvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
break;
case scm_tc7_cvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3);
+ SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj);
((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:
+ case scm_tc7_wvect:
SCM_VELTS (v)[pos] = obj;
break;
}
}
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))
default:
return SCM_BOOL_F;
case scm_tc7_vector:
+ case scm_tc7_wvect:
case scm_tc7_string:
case scm_tc7_bvect:
case scm_tc7_byvect:
}
}
-#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_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_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x);
+
SCM
-scm_uniform_array_read_x (ra, port)
+scm_uniform_array_read_x (ra, port_or_fd, start, end)
SCM ra;
- SCM port;
-#endif
+ SCM port_or_fd;
+ SCM start;
+ SCM end;
{
- 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 cra = SCM_UNDEFINED, v = ra;
+ long sz, vlen, ans;
+ long cstart = 0;
+ long cend;
+ long offset = 0;
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- len = SCM_LENGTH (v);
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_cur_inp;
+ else
+ SCM_ASSERT (SCM_INUMP (port_or_fd)
+ || (SCM_NIMP (port_or_fd) && SCM_OPINFPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, s_uniform_array_read_x);
+ vlen = SCM_LENGTH (v);
+
loop:
- switch SCM_TYP7
- (v)
+ 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 *
+ cstart += SCM_ARRAY_BASE (cra);
+ vlen = SCM_ARRAY_DIMS (cra)->inc *
(SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
v = SCM_ARRAY_V (cra);
goto loop;
sz = sizeof (char);
break;
case scm_tc7_bvect:
- len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- start /= SCM_LONG_BIT;
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
sz = sizeof (long);
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))
+
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ offset =
+ scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x);
+
+ if (offset < 0 || offset >= cend)
+ scm_out_of_range (s_uniform_array_read_x, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ long tend =
+ scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x);
+
+ if (tend <= offset || tend > cend)
+ scm_out_of_range (s_uniform_array_read_x, end);
+ cend = tend;
+ }
+ }
- { /* UGGH!!! */
- ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port));
- SCM_CLRDY (port); /* Clear ungetted char */
+ if (SCM_NIMP (port_or_fd))
+ {
+ /* if we have stored a character from the port in our own buffer,
+ push it back onto the stream. */
+ /* 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_or_fd))
+ {
+ ungetc (SCM_CGETUN (port_or_fd), (FILE *)SCM_STREAM (port_or_fd));
+ SCM_CLRDY (port_or_fd); /* Clear ungetted char */
+ }
+ SCM_SYSCALL (ans = fread (SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) sz, (scm_sizet) (cend - offset),
+ (FILE *)SCM_STREAM (port_or_fd)));
+ }
+ else /* file descriptor. */
+ {
+ SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
+ SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) (sz * (cend - offset))));
+ if (ans == -1)
+ scm_syserror (s_uniform_array_read_x);
}
- 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_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write);
+
SCM
-scm_uniform_array_write (v, port)
+scm_uniform_array_write (v, port_or_fd, start, end)
SCM v;
- SCM port;
-#endif
+ SCM port_or_fd;
+ SCM start;
+ SCM end;
{
- 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);
+ long sz, vlen, ans;
+ long offset = 0;
+ long cstart = 0;
+ long cend;
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- len = SCM_LENGTH (v);
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_cur_outp;
+ else
+ SCM_ASSERT (SCM_INUMP (port_or_fd)
+ || (SCM_NIMP (port_or_fd) && SCM_OPOUTFPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, s_uniform_array_write);
+ vlen = SCM_LENGTH (v);
+
loop:
- switch SCM_TYP7
- (v)
+ 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);
+ cstart = SCM_ARRAY_BASE (v);
+ vlen = 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:
+ 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;
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
sz = sizeof (long);
break;
#endif
}
- SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
+
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ offset =
+ scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write);
+
+ if (offset < 0 || offset >= cend)
+ scm_out_of_range (s_uniform_array_write, start);
+
+ if (!SCM_UNBNDP (end))
+ {
+ long tend =
+ scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write);
+
+ if (tend <= offset || tend > cend)
+ scm_out_of_range (s_uniform_array_write, end);
+ cend = tend;
+ }
+ }
+
+ if (SCM_NIMP (port_or_fd))
+ {
+ SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) sz, (scm_sizet) (cend - offset),
+ (FILE *)SCM_STREAM (port_or_fd)));
+ }
+ else /* file descriptor. */
+ {
+ SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
+ SCM_CHARS (v) + (cstart + offset) * sz,
+ (scm_sizet) (sz * (cend - offset))));
+ if (ans == -1)
+ scm_syserror (s_uniform_array_write);
+ }
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_LONG_BIT;
+
return SCM_MAKINUM (ans);
}
{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_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_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_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_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);
}
-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);
}
-#ifdef __STDC__
-static SCM
-ra2l (SCM ra, scm_sizet base, scm_sizet k)
-#else
+
+static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));
+
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;
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_ARRAYP (v), badarg1);
return ra2l (v, SCM_ARRAY_BASE (v), 0);
case scm_tc7_vector:
+ case scm_tc7_wvect:
return scm_vector_to_list (v);
case scm_tc7_string:
return scm_string_to_list (v);
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)
+ for (mask = 1UL << (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);
}
-static char s_bad_ralst[] = "Bad scm_array contents scm_list";
-static int l2ra ();
+static char s_bad_ralst[] = "Bad scm_array contents list";
+
+static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));
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;
while (k--)
{
n = scm_ilength (row);
- SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array);
+ SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array);
shp = scm_cons (SCM_MAKINUM (n), shp);
if (SCM_NIMP (row))
row = SCM_CAR (row);
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);
return ok;
}
-#ifdef __STDC__
-static void
-rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing)
-#else
+
+static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));
+
static void
-rapr1 (ra, j, k, port, writing)
+rapr1 (ra, j, k, port, pstate)
SCM ra;
scm_sizet j;
scm_sizet k;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
long inc = 1;
long n = SCM_LENGTH (ra);
{
SCM_ARRAY_BASE (ra) = j;
if (n-- > 0)
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_putc (' ', port);
SCM_ARRAY_BASE (ra) = j;
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
}
break;
}
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);
+ scm_putc ('(', port);
+ rapr1 (ra, j, k + 1, port, pstate);
+ scm_puts (") ", 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);
+ scm_putc ('(', port);
+ rapr1 (ra, j, k + 1, port, pstate);
+ scm_putc (')', port);
}
break;
}
goto tail;
default:
if (n-- > 0)
- scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, writing);
+ scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
- scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
+ scm_putc (' ', port);
+ scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
}
break;
case scm_tc7_string:
if (n-- > 0)
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
- if (writing)
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
+ if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
+ scm_putc (' ', port);
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
}
else
for (j += inc; n-- > 0; j += inc)
- scm_gen_putc (SCM_CHARS (ra)[j], port);
+ scm_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_putc (' ', port);
scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
}
break;
scm_intprint (SCM_VELTS (ra)[j], 10, port);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_putc (' ', port);
scm_intprint (SCM_VELTS (ra)[j], 10, port);
}
break;
scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_putc (' ', port);
scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
}
break;
{
SCM z = scm_makflo (1.0);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_putc (' ', port);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
{
SCM z = scm_makdbl (1.0 / 3.0, 0.0);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_putc (' ', port);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
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);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
- scm_gen_putc (' ', port);
+ scm_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);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
}
}
break;
}
-#ifdef __STDC__
-int
-scm_raprin1 (SCM exp, SCM port, int writing)
-#else
+
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
SCM v = exp;
scm_sizet base = 0;
- scm_gen_putc ('#', port);
+ scm_putc ('#', port);
tail:
switch SCM_TYP7
(v)
if (SCM_ARRAYP (v))
{
- scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
- rapr1 (exp, base, 0, port, writing);
- scm_gen_putc ('>', port);
+ scm_puts ("<enclosed-array ", port);
+ rapr1 (exp, base, 0, port, pstate);
+ scm_putc ('>', port);
return 1;
}
else
if (exp == v)
{ /* a uve, not an scm_array */
register long i, j, w;
- scm_gen_putc ('*', port);
+ scm_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);
+ scm_putc (w & 1 ? '1' : '0', port);
w >>= 1;
}
}
w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
for (; j; j--)
{
- scm_gen_putc (w & 1 ? '1' : '0', port);
+ scm_putc (w & 1 ? '1' : '0', port);
w >>= 1;
}
}
return 1;
}
else
- scm_gen_putc ('b', port);
+ scm_putc ('b', port);
break;
case scm_tc7_string:
- scm_gen_putc ('a', port);
+ scm_putc ('a', port);
break;
case scm_tc7_byvect:
- scm_gen_puts (scm_regular_string, "bytes", port);
+ scm_puts ("bytes", port);
break;
case scm_tc7_uvect:
- scm_gen_putc ('u', port);
+ scm_putc ('u', port);
break;
case scm_tc7_ivect:
- scm_gen_putc ('e', port);
+ scm_putc ('e', port);
break;
case scm_tc7_svect:
- scm_gen_puts (scm_regular_string, "short", port);
+ scm_puts ("short", port);
break;
#ifdef LONGLONGS
case scm_tc7_llvect:
- scm_gen_puts (scm_regular_string, "long_long", port);
+ scm_puts ("long_long", port);
break;
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- scm_gen_putc ('s', port);
+ scm_putc ('s', port);
break;
#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
- scm_gen_putc ('i', port);
+ scm_putc ('i', port);
break;
case scm_tc7_cvect:
- scm_gen_putc ('c', port);
+ scm_putc ('c', port);
break;
#endif /*SCM_FLOATS*/
}
- scm_gen_putc ('(', port);
- rapr1 (exp, base, 0, port, writing);
- scm_gen_putc (')', port);
+ scm_putc ('(', port);
+ rapr1 (exp, base, 0, port, pstate);
+ scm_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);
ra = SCM_ARRAY_V (ra);
goto loop;
case scm_tc7_vector:
+ case scm_tc7_wvect:
return SCM_EOL;
case scm_tc7_bvect:
return SCM_BOOL_T;
}
}
-#ifdef __STDC__
-static SCM
-markra (SCM ptr)
-#else
+
+static SCM markra SCM_P ((SCM ptr));
+
static SCM
markra (ptr)
SCM ptr;
-#endif
{
if SCM_GC8MARKP
(ptr) return SCM_BOOL_F;
return SCM_ARRAY_V (ptr);
}
-#ifdef __STDC__
-static scm_sizet
-freera (SCM ptr)
-#else
+
+static scm_sizet freera SCM_P ((SCM ptr));
+
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);
/* 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);
#else /* ARRAYS */
-#ifdef __STDC__
-int
-scm_raprin1 (SCM exp, SCM port, int writing)
-#else
+
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
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 ()
{
+#include "unif.x"
scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
}
#endif /* ARRAYS */
-
-
-
-
HCoop / bpt / guile.git / blobdiff