X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/fe0c6dae02130c3e66f9c1c2291101821fb89f04..ab256d39098ffb1ac986290bde36c9713d0f262e:/libguile/unif.c diff --git a/libguile/unif.c b/libguile/unif.c index 5d604eeda..9a675954a 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* 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 @@ -12,7 +12,8 @@ * * 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. @@ -36,8 +37,7 @@ * * 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. */ #include @@ -46,13 +46,16 @@ #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 +#endif + /* The set of uniform scm_vector types is: * Vector of: Called: @@ -79,15 +82,11 @@ long scm_tc16_array; */ 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; @@ -100,12 +99,12 @@ scm_vector_set_length_x (vect, len) 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; @@ -176,21 +175,16 @@ scm_vector_set_length_x (vect, len) #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; @@ -198,15 +192,11 @@ scm_makflo (x) #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; @@ -295,14 +285,10 @@ scm_make_uve (k, prot) } 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 @@ -319,6 +305,7 @@ scm_uniform_vector_length (v) 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: @@ -328,15 +315,11 @@ scm_uniform_vector_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; @@ -391,6 +374,7 @@ loop: 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:; } @@ -399,14 +383,10 @@ loop: 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; @@ -416,6 +396,7 @@ scm_array_rank (ra) 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: @@ -436,14 +417,10 @@ scm_array_rank (ra) 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; @@ -456,6 +433,7 @@ scm_array_dimensions (ra) 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: @@ -484,16 +462,12 @@ scm_array_dimensions (ra) 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; @@ -501,7 +475,6 @@ scm_aind (ra, args, what) 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_makfrom0str (what), SCM_WNA, NULL); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); @@ -523,21 +496,17 @@ scm_aind (ra, args, what) } -#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; @@ -546,15 +515,11 @@ scm_make_ra (ndim) 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; @@ -569,18 +534,21 @@ scm_shap2ra (args, what) 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; } @@ -589,16 +557,12 @@ scm_shap2ra (args, what) } 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; @@ -627,7 +591,7 @@ scm_dimensions_to_uniform_array (dims, prot, fill) 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--) @@ -684,14 +648,10 @@ scm_dimensions_to_uniform_array (dims, prot, fill) 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); if (k) @@ -701,28 +661,24 @@ scm_ra_set_contp (ra) { if (inc != SCM_ARRAY_DIMS (ra)[k].inc) { - SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS; + SCM_SETAND_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_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; @@ -767,7 +723,7 @@ scm_make_shared_array (oldra, mapfunc, dims) 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 @@ -788,7 +744,7 @@ scm_make_shared_array (oldra, mapfunc, dims) { 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)) @@ -831,14 +787,10 @@ scm_make_shared_array (oldra, mapfunc, dims) /* 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; @@ -851,7 +803,7 @@ scm_transpose_array (args) switch (SCM_TYP7 (ra)) { default: - badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array); + badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -880,9 +832,11 @@ scm_transpose_array (args) 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; } @@ -919,7 +873,7 @@ scm_transpose_array (args) 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; } @@ -927,14 +881,10 @@ scm_transpose_array (args) /* 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; @@ -963,6 +913,7 @@ scm_enclose_array (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: @@ -1014,14 +965,10 @@ scm_enclose_array (axes) 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; @@ -1090,6 +1037,7 @@ tail: 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; } @@ -1098,25 +1046,20 @@ tail: 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); @@ -1143,7 +1086,9 @@ scm_uniform_vector_ref (v, args) default: if (SCM_NULLP (args)) return v; - badarg:scm_wta (v, (char *) SCM_ARG1, 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: @@ -1199,22 +1144,19 @@ scm_uniform_vector_ref (v, args) ((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) @@ -1278,6 +1220,7 @@ scm_cvref (v, pos, last) ((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 */ @@ -1298,21 +1241,18 @@ scm_cvref (v, pos, last) 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); @@ -1320,23 +1260,24 @@ scm_array_set_x (v, obj, args) 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); + 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 */ @@ -1347,38 +1288,38 @@ scm_array_set_x (v, obj, args) 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 @@ -1386,21 +1327,22 @@ scm_array_set_x (v, obj, args) #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; } @@ -1408,15 +1350,11 @@ scm_array_set_x (v, obj, args) } 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)) @@ -1427,6 +1365,7 @@ scm_array_contents (ra, strict) 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: @@ -1474,15 +1413,11 @@ scm_array_contents (ra, strict) } } -#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; @@ -1516,37 +1451,40 @@ scm_ra2contig (ra, copy) -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; @@ -1555,8 +1493,8 @@ 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); @@ -1583,61 +1521,104 @@ loop: 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); - { /* UGGH!!! */ - ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port)); - SCM_CLRDY (port); /* Clear ungetted char */ + 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; + } + } + + 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); @@ -1664,9 +1645,44 @@ loop: 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); } @@ -1675,15 +1691,11 @@ 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; @@ -1716,16 +1728,12 @@ scm_bit_count (item, seq) 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; @@ -1789,16 +1797,12 @@ scm_bit_position (item, v, k) 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); @@ -1851,16 +1855,12 @@ scm_bit_set_star_x (v, kv, obj) 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; @@ -1922,14 +1922,10 @@ scm_bit_count_star (v, kv, obj) 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); @@ -1948,72 +1944,10 @@ scm_bit_invert_x (v) } -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); @@ -2042,16 +1976,14 @@ scm_istr2bve (str, len) } -#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; @@ -2080,14 +2012,10 @@ ra2l (ra, base, k) 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; @@ -2101,6 +2029,7 @@ scm_array_to_list (v) 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); @@ -2109,7 +2038,7 @@ scm_array_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); @@ -2185,24 +2114,17 @@ scm_array_to_list (v) } -static char s_bad_ralst[] = "Bad scm_array contents scm_list"; -#ifdef __STDC__ -static int l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k); -#else -static int l2ra (); -#endif +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; @@ -2214,7 +2136,7 @@ scm_list_to_uniform_array (ndim, prot, 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); @@ -2240,18 +2162,12 @@ scm_list_to_uniform_array (ndim, prot, lst) 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); @@ -2287,10 +2203,9 @@ l2ra (lst, ra, base, k) return ok; } -#ifdef __STDC__ -static void -rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate) -#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, pstate) SCM ra; @@ -2298,7 +2213,6 @@ rapr1 (ra, j, k, port, pstate) scm_sizet k; SCM port; scm_print_state *pstate; -#endif { long inc = 1; long n = SCM_LENGTH (ra); @@ -2315,7 +2229,7 @@ tail: 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, pstate); } @@ -2327,16 +2241,16 @@ tail: 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); + scm_putc ('(', port); rapr1 (ra, j, k + 1, port, pstate); - scm_gen_puts (scm_regular_string, ") ", port); + scm_puts (") ", port); j += inc; } if (i == SCM_ARRAY_DIMS (ra)[k].ubnd) { /* could be zero size. */ - scm_gen_putc ('(', port); + scm_putc ('(', port); rapr1 (ra, j, k + 1, port, pstate); - scm_gen_putc (')', port); + scm_putc (')', port); } break; } @@ -2355,7 +2269,7 @@ tail: scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate); for (j += inc; n-- > 0; j += inc) { - scm_gen_putc (' ', port); + scm_putc (' ', port); scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); } break; @@ -2365,19 +2279,19 @@ tail: if (SCM_WRITINGP (pstate)) for (j += inc; n-- > 0; j += inc) { - scm_gen_putc (' ', port); + 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; @@ -2388,7 +2302,7 @@ tail: 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; @@ -2398,7 +2312,7 @@ tail: 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; @@ -2413,7 +2327,7 @@ tail: 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, pstate); } @@ -2428,7 +2342,7 @@ tail: 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, pstate); } @@ -2443,7 +2357,7 @@ tail: 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, pstate); @@ -2455,20 +2369,16 @@ tail: } -#ifdef __STDC__ -int -scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) -#else + int scm_raprin1 (exp, port, pstate) SCM exp; SCM port; scm_print_state *pstate; -#endif { SCM v = exp; scm_sizet base = 0; - scm_gen_putc ('#', port); + scm_putc ('#', port); tail: switch SCM_TYP7 (v) @@ -2481,9 +2391,9 @@ tail: if (SCM_ARRAYP (v)) { - scm_gen_puts (scm_regular_string, "', port); + scm_putc ('>', port); return 1; } else @@ -2496,13 +2406,13 @@ tail: 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; } } @@ -2512,64 +2422,60 @@ tail: 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); + scm_putc ('(', port); rapr1 (exp, base, 0, port, pstate); - scm_gen_putc (')', port); + 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); @@ -2586,6 +2492,7 @@ loop: 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; @@ -2616,14 +2523,12 @@ loop: } } -#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; @@ -2631,14 +2536,12 @@ markra (ptr) 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); @@ -2649,13 +2552,9 @@ static scm_smobfuns rasmob = /* 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); @@ -2664,29 +2563,21 @@ scm_init_unif () #else /* ARRAYS */ -#ifdef __STDC__ -int -scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) -#else + int scm_raprin1 (exp, port, pstate) SCM exp; SCM port; scm_print_state *pstate; -#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; } @@ -2694,11 +2585,8 @@ scm_istr2bve (str, len) void scm_init_unif () { +#include "unif.x" scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); } #endif /* ARRAYS */ - - - -