diff options
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 526 |
1 files changed, 236 insertions, 290 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index 0384099d1..c3d649480 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -38,6 +38,10 @@ * 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. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include <stdio.h> @@ -49,6 +53,7 @@ #include "strop.h" #include "feature.h" +#include "scm_validate.h" #include "unif.h" #include "ramap.h" @@ -147,9 +152,7 @@ scm_makflo (float x) SCM -scm_make_uve (k, prot) - long k; - SCM prot; +scm_make_uve (long k, SCM prot) { SCM v; long i, type; @@ -234,18 +237,17 @@ scm_make_uve (k, prot) return v; } -SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length); - -SCM -scm_uniform_vector_length (v) - SCM v; +GUILE_PROC(scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_uniform_vector_length { SCM_ASRTGO (SCM_NIMP (v), badarg1); switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length); + badarg1:SCM_WTA(1,v); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -263,13 +265,12 @@ scm_uniform_vector_length (v) return SCM_MAKINUM (SCM_LENGTH (v)); } } +#undef FUNC_NAME -SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p); - -SCM -scm_array_p (v, prot) - SCM v; - SCM prot; +GUILE_PROC(scm_array_p, "array?", 1, 1, 0, + (SCM v, SCM prot), +"") +#define FUNC_NAME s_scm_array_p { int nprot; int enclosed; @@ -290,15 +291,15 @@ loop: v = SCM_ARRAY_V (v); goto loop; case scm_tc7_bvect: - return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_BOOL_T==prot); case scm_tc7_string: - return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))); case scm_tc7_byvect: - return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(prot == SCM_MAKICHR('\0')); case scm_tc7_uvect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); case scm_tc7_ivect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); case scm_tc7_svect: return ( nprot || (SCM_NIMP (prot) @@ -316,30 +317,30 @@ loop: # ifdef SCM_FLOATS # ifdef SCM_SINGLES case scm_tc7_fvect: - return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_SINGP(prot)); # endif case scm_tc7_dvect: - return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_REALP(prot)); case scm_tc7_cvect: - return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NIMP(prot) && SCM_CPLXP(prot)); # endif case scm_tc7_vector: case scm_tc7_wvect: - return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F; + return nprot || SCM_BOOL(SCM_NULLP(prot)); default:; } return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank); - -SCM -scm_array_rank (ra) - SCM ra; +GUILE_PROC(scm_array_rank, "array-rank", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_rank { if (SCM_IMP (ra)) - return SCM_INUM0; + return SCM_INUM0; switch (SCM_TYP7 (ra)) { default: @@ -364,19 +365,19 @@ scm_array_rank (ra) return SCM_INUM0; } } +#undef FUNC_NAME -SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions); - -SCM -scm_array_dimensions (ra) - SCM ra; +GUILE_PROC(scm_array_dimensions, "array-dimensions", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_dimensions { SCM res = SCM_EOL; scm_sizet k; scm_array_dim *s; if (SCM_IMP (ra)) - return SCM_BOOL_F; + return SCM_BOOL_F; switch (SCM_TYP7 (ra)) { default: @@ -408,16 +409,14 @@ scm_array_dimensions (ra) return res; } } +#undef FUNC_NAME static char s_bad_ind[] = "Bad scm_array index"; long -scm_aind (ra, args, what) - SCM ra; - SCM args; - const char *what; +scm_aind (SCM ra, SCM args, const char *what) { SCM ind; register long j; @@ -448,8 +447,7 @@ scm_aind (ra, args, what) SCM -scm_make_ra (ndim) - int ndim; +scm_make_ra (int ndim) { SCM ra; SCM_NEWCELL (ra); @@ -467,9 +465,7 @@ static char s_bad_spec[] = "Bad scm_array dimension"; SCM -scm_shap2ra (args, what) - SCM args; - const char *what; +scm_shap2ra (SCM args, const char *what) { scm_array_dim *s; SCM ra, spec, sp; @@ -506,13 +502,10 @@ scm_shap2ra (args, what) return ra; } -SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, scm_dimensions_to_uniform_array); - -SCM -scm_dimensions_to_uniform_array (dims, prot, fill) - SCM dims; - SCM prot; - SCM fill; +GUILE_PROC(scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, + (SCM dims, SCM prot, SCM fill), +"") +#define FUNC_NAME s_scm_dimensions_to_uniform_array { scm_sizet k, vlen = 1; long rlen = 1; @@ -536,8 +529,8 @@ scm_dimensions_to_uniform_array (dims, prot, fill) 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); + dims, SCM_ARG1, FUNC_NAME); + ra = scm_shap2ra (dims, FUNC_NAME); SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); @@ -591,11 +584,11 @@ scm_dimensions_to_uniform_array (dims, prot, fill) return SCM_ARRAY_V (ra); return ra; } +#undef FUNC_NAME void -scm_ra_set_contp (ra) - SCM ra; +scm_ra_set_contp (SCM ra) { scm_sizet k = SCM_ARRAY_NDIM (ra); if (k) @@ -616,13 +609,10 @@ scm_ra_set_contp (ra) } -SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); - -SCM -scm_make_shared_array (oldra, mapfunc, dims) - SCM oldra; - SCM mapfunc; - SCM dims; +GUILE_PROC(scm_make_shared_array, "make-shared-array", 2, 0, 1, + (SCM oldra, SCM mapfunc, SCM dims), +"") +#define FUNC_NAME s_scm_make_shared_array { SCM ra; SCM inds, indptr; @@ -630,9 +620,9 @@ scm_make_shared_array (oldra, mapfunc, dims) 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); + SCM_VALIDATE_ARRAY(1,oldra); + SCM_VALIDATE_PROC(2,mapfunc); + ra = scm_shap2ra (dims, FUNC_NAME); if (SCM_ARRAYP (oldra)) { SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra); @@ -669,14 +659,14 @@ scm_make_shared_array (oldra, mapfunc, dims) } imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array); + i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME); 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, s_bad_ind, FUNC_NAME); imap = SCM_CAR (imap); } i = SCM_INUM (imap); @@ -692,14 +682,14 @@ scm_make_shared_array (oldra, mapfunc, dims) 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; + s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - 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, s_bad_ind, FUNC_NAME); imap = SCM_CAR (imap); } s[k].inc = (long) SCM_INUM (imap) - i; @@ -715,7 +705,7 @@ scm_make_shared_array (oldra, mapfunc, dims) indptr = SCM_CDR (indptr); } SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, - "mapping out of range", s_make_shared_array); + "mapping out of range", FUNC_NAME); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) { if (1 == s->inc && 0 == s->lbnd @@ -727,27 +717,27 @@ scm_make_shared_array (oldra, mapfunc, dims) scm_ra_set_contp (ra); return ra; } +#undef FUNC_NAME /* args are RA . DIMS */ -SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array); - -SCM -scm_transpose_array (args) - SCM args; +GUILE_PROC(scm_transpose_array, "transpose-array", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_transpose_array { SCM ra, res, vargs, *ve = &vargs; scm_array_dim *s, *r; int ndim, i, k; - SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array), + SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); ra = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array); + SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); args = SCM_CDR (args); switch (SCM_TYP7 (ra)) { default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array); + badarg:SCM_WTA (1,ra); case scm_tc7_bvect: case scm_tc7_string: case scm_tc7_byvect: @@ -761,26 +751,26 @@ scm_transpose_array (args) case scm_tc7_llvect: #endif SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); + scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, - s_transpose_array); + FUNC_NAME); SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE, - s_transpose_array); + FUNC_NAME); 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_makfrom0str (s_transpose_array), SCM_WNA, NULL); + scm_makfrom0str (FUNC_NAME), 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); + FUNC_NAME); i = SCM_INUM (ve[k]); SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k], - SCM_OUTOFRANGE, s_transpose_array); + SCM_OUTOFRANGE, FUNC_NAME); if (ndim < i) ndim = i; } @@ -817,28 +807,27 @@ scm_transpose_array (args) r->inc += s->inc; } } - SCM_ASSERT (ndim <= 0, args, "bad argument list", s_transpose_array); + SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME); scm_ra_set_contp (res); return res; } } +#undef FUNC_NAME /* args are RA . AXES */ -SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array); - -SCM -scm_enclose_array (axes) - SCM axes; +GUILE_PROC(scm_enclose_array, "enclose-array", 0, 0, 1, + (SCM axes), +"") +#define FUNC_NAME s_scm_enclose_array { SCM axv, ra, res, ra_inr; scm_array_dim vdim, *s = &vdim; int ndim, j, k, ninr, noutr; - SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA, + SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); 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); @@ -847,7 +836,7 @@ scm_enclose_array (axes) (ra) { default: - badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array); + badarg1:SCM_WTA (1,ra); case scm_tc7_string: case scm_tc7_bvect: case scm_tc7_byvect: @@ -879,14 +868,14 @@ scm_enclose_array (axes) } noutr = ndim - ninr; axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); - SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array), + SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); 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); + SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", FUNC_NAME); 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; @@ -905,21 +894,21 @@ scm_enclose_array (axes) scm_ra_set_contp (res); return res; } +#undef FUNC_NAME -SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p); - -SCM -scm_array_in_bounds_p (args) - SCM args; +GUILE_PROC(scm_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, + (SCM args), +"") +#define FUNC_NAME s_scm_array_in_bounds_p { SCM v, ind = SCM_EOL; long pos = 0; register scm_sizet k; register long j; scm_array_dim *s; - SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p), + SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL); v = SCM_CAR (args); args = SCM_CDR (args); @@ -929,7 +918,7 @@ scm_array_in_bounds_p (args) { ind = SCM_CAR (args); args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p); + SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME); pos = SCM_INUM (ind); } tail: @@ -937,8 +926,8 @@ tail: (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p)); + badarg1:SCM_WTA (1,v); + wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME)); case scm_tc7_smob: k = SCM_ARRAY_NDIM (v); s = SCM_ARRAY_DIMS (v); @@ -963,7 +952,7 @@ tail: ind = SCM_CAR (args); args = SCM_CDR (args); s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p); + SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME); } SCM_ASRTGO (0 == k, wna); v = SCM_ARRAY_V (v); @@ -983,18 +972,19 @@ tail: 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; + return SCM_BOOL(pos >= 0 && pos < SCM_LENGTH (v)); } } +#undef FUNC_NAME -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); +SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); -SCM -scm_uniform_vector_ref (v, args) - SCM v; - SCM args; + +GUILE_PROC(scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, + (SCM v, SCM args), +"") +#define FUNC_NAME s_scm_uniform_vector_ref { long pos; @@ -1005,7 +995,7 @@ scm_uniform_vector_ref (v, args) } else if (SCM_ARRAYP (v)) { - pos = scm_aind (v, args, s_uniform_vector_ref); + pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } else @@ -1013,13 +1003,13 @@ scm_uniform_vector_ref (v, args) if (SCM_NIMP (args)) { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref); + SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME); 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); + SCM_VALIDATE_INT(2,args); pos = SCM_INUM (args); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); @@ -1031,10 +1021,10 @@ scm_uniform_vector_ref (v, args) if (SCM_NULLP (args)) return v; badarg: - scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); + SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref)); + outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1092,6 +1082,7 @@ scm_uniform_vector_ref (v, args) return SCM_VELTS (v)[pos]; } } +#undef FUNC_NAME /* 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.) */ @@ -1182,22 +1173,21 @@ 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); +SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); + /* 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; +GUILE_PROC(scm_array_set_x, "array-set!", 2, 0, 1, + (SCM v, SCM obj, SCM args), +"") +#define FUNC_NAME s_scm_array_set_x { long pos = 0; SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) { - pos = scm_aind (v, args, s_array_set_x); + pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } else @@ -1205,24 +1195,23 @@ scm_array_set_x (v, obj, args) if (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, - SCM_ARG3, s_array_set_x); + SCM_ARG3, FUNC_NAME); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); pos = SCM_INUM (SCM_CAR (args)); } else { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x); - pos = SCM_INUM (args); + SCM_VALIDATE_INT_COPY(3,args,pos); } 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); + SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x)); + outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: @@ -1231,7 +1220,7 @@ 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 - badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x); + badobj:SCM_WTA (2,obj); break; case scm_tc7_string: SCM_ASRTGO (SCM_ICHRP (obj), badobj); @@ -1245,24 +1234,23 @@ scm_array_set_x (v, obj, args) break; # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); + SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); + /* fall through */ case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badobj); 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_ARG2, s_array_set_x); break; - case scm_tc7_ivect: - SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, s_array_set_x); break; + case scm_tc7_uvect: + SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break; + case scm_tc7_ivect: + SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break; # endif - break; - case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); break; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x); + ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME); break; #endif @@ -1270,11 +1258,11 @@ scm_array_set_x (v, obj, args) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, s_array_set_x); break; + ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, FUNC_NAME); break; break; #endif case scm_tc7_dvect: - ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, s_array_set_x); break; + ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, FUNC_NAME); break; break; case scm_tc7_cvect: SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj); @@ -1289,16 +1277,16 @@ scm_array_set_x (v, obj, args) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME /* attempts to unroll an array into a one-dimensional array. returns the unrolled array or #f if it can't be done. */ -SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents); - -SCM -scm_array_contents (ra, strict) - SCM ra; - SCM strict; /* if not SCM_UNDEFINED, return #f if returned array + /* if strict is not SCM_UNDEFINED, return #f if returned array wouldn't have contiguous elements. */ +GUILE_PROC(scm_array_contents, "array-contents", 1, 1, 0, + (SCM ra, SCM strict), +"") +#define FUNC_NAME s_scm_array_contents { SCM sra; if (SCM_IMP (ra)) @@ -1353,6 +1341,7 @@ scm_array_contents (ra, strict) } } } +#undef FUNC_NAME SCM @@ -1392,14 +1381,10 @@ scm_ra2contig (ra, copy) -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_or_fd, start, end) - SCM ra; - SCM port_or_fd; - SCM start; - SCM end; +GUILE_PROC(scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, + (SCM ra, SCM port_or_fd, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_uniform_array_read_x { SCM cra = SCM_UNDEFINED, v = ra; long sz, vlen, ans; @@ -1413,14 +1398,14 @@ scm_uniform_array_read_x (ra, port_or_fd, start, end) else SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_NIMP (port_or_fd) && SCM_OPINPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, s_uniform_array_read_x); + port_or_fd, SCM_ARG2, FUNC_NAME); vlen = SCM_LENGTH (v); loop: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); + badarg1:scm_wta (v, (char *) SCM_ARG1, FUNC_NAME); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); cra = scm_ra2contig (ra, 0); @@ -1467,18 +1452,18 @@ loop: if (!SCM_UNBNDP (start)) { offset = - scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x); + scm_num2long (start, (char *) SCM_ARG3, FUNC_NAME); if (offset < 0 || offset >= cend) - scm_out_of_range (s_uniform_array_read_x, start); + scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { long tend = - scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x); + scm_num2long (end, (char *) SCM_ARG4, FUNC_NAME); if (tend <= offset || tend > cend) - scm_out_of_range (s_uniform_array_read_x, end); + scm_out_of_range (FUNC_NAME, end); cend = tend; } } @@ -1511,7 +1496,7 @@ loop: { if (remaining % sz != 0) { - scm_misc_error (s_uniform_array_read_x, + scm_misc_error (FUNC_NAME, "unexpected EOF", SCM_EOL); } @@ -1530,7 +1515,7 @@ loop: SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) - scm_syserror (s_uniform_array_read_x); + SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; @@ -1540,15 +1525,12 @@ loop: return SCM_MAKINUM (ans); } +#undef FUNC_NAME -SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write); - -SCM -scm_uniform_array_write (v, port_or_fd, start, end) - SCM v; - SCM port_or_fd; - SCM start; - SCM end; +GUILE_PROC(scm_uniform_array_write, "uniform-array-write", 1, 3, 0, + (SCM v, SCM port_or_fd, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_uniform_array_write { long sz, vlen, ans; long offset = 0; @@ -1563,14 +1545,14 @@ scm_uniform_array_write (v, port_or_fd, start, end) else SCM_ASSERT (SCM_INUMP (port_or_fd) || (SCM_NIMP (port_or_fd) && SCM_OPOUTPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, s_uniform_array_write); + port_or_fd, SCM_ARG2, FUNC_NAME); vlen = SCM_LENGTH (v); loop: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); + badarg1:scm_wta (v, (char *) SCM_ARG1, FUNC_NAME); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); v = scm_ra2contig (v, 1); @@ -1617,18 +1599,18 @@ loop: if (!SCM_UNBNDP (start)) { offset = - scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write); + scm_num2long (start, (char *) SCM_ARG3, FUNC_NAME); if (offset < 0 || offset >= cend) - scm_out_of_range (s_uniform_array_write, start); + scm_out_of_range (FUNC_NAME, start); if (!SCM_UNBNDP (end)) { long tend = - scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write); + scm_num2long (end, (char *) SCM_ARG4, FUNC_NAME); if (tend <= offset || tend > cend) - scm_out_of_range (s_uniform_array_write, end); + scm_out_of_range (FUNC_NAME, end); cend = tend; } } @@ -1646,32 +1628,31 @@ loop: SCM_CHARS (v) + (cstart + offset) * sz, (scm_sizet) (sz * (cend - offset)))); if (ans == -1) - scm_syserror (s_uniform_array_write); + SCM_SYSERROR; } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; return SCM_MAKINUM (ans); } +#undef FUNC_NAME 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); - -SCM -scm_bit_count (item, seq) - SCM item; - SCM seq; +GUILE_PROC(scm_bit_count, "bit-count", 2, 0, 0, + (SCM item, SCM seq), +"") +#define FUNC_NAME s_scm_bit_count { long i; register unsigned long cnt = 0, w; - SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count); + SCM_VALIDATE_INT(2,seq); switch SCM_TYP7 (seq) { default: - scm_wta (seq, (char *) SCM_ARG2, s_bit_count); + SCM_WTA (2,seq); case scm_tc7_bvect: if (0 == SCM_LENGTH (seq)) return SCM_INUM0; @@ -1692,28 +1673,26 @@ scm_bit_count (item, seq) } } } +#undef FUNC_NAME -SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position); - -SCM -scm_bit_position (item, v, k) - SCM item; - SCM v; - SCM k; +GUILE_PROC(scm_bit_position, "bit-position", 3, 0, 0, + (SCM item, SCM v, SCM k), +"") +#define FUNC_NAME s_scm_bit_position { - long i, lenw, xbits, pos = SCM_INUM (k); + long i, lenw, xbits, pos; 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_VALIDATE_NIMP(2,v); + SCM_VALIDATE_INT_COPY(3,k,pos); SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, s_bit_position); + k, SCM_OUTOFRANGE, FUNC_NAME); if (pos == SCM_LENGTH (v)) return SCM_BOOL_F; switch SCM_TYP7 (v) { default: - scm_wta (v, (char *) SCM_ARG2, s_bit_position); + SCM_WTA (2,v); case scm_tc7_bvect: if (0 == SCM_LENGTH (v)) return SCM_MAKINUM (-1L); @@ -1760,15 +1739,13 @@ scm_bit_position (item, v, k) return SCM_BOOL_F; } } +#undef FUNC_NAME -SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x); - -SCM -scm_bit_set_star_x (v, kv, obj) - SCM v; - SCM kv; - SCM obj; +GUILE_PROC(scm_bit_set_star_x, "bit-set*!", 3, 0, 0, + (SCM v, SCM kv, SCM obj), +"") +#define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1776,30 +1753,30 @@ scm_bit_set_star_x (v, kv, obj) switch SCM_TYP7 (kv) { default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x); + badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x); + badarg1:SCM_WTA (1,v); 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_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); 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_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); 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); + badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: @@ -1816,15 +1793,13 @@ scm_bit_set_star_x (v, kv, obj) } return SCM_UNSPECIFIED; } +#undef FUNC_NAME -SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star); - -SCM -scm_bit_count_star (v, kv, obj) - SCM v; - SCM kv; - SCM obj; +GUILE_PROC(scm_bit_count_star, "bit-count*", 3, 0, 0, + (SCM v, SCM kv, SCM obj), +"") +#define FUNC_NAME s_scm_bit_count_star { register long i, vlen, count = 0; register unsigned long k; @@ -1833,20 +1808,20 @@ scm_bit_count_star (v, kv, obj) switch SCM_TYP7 (kv) { default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star); + badarg2:SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star); + badarg1:SCM_WTA (1,v); 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); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) count++; } @@ -1854,12 +1829,12 @@ scm_bit_count_star (v, kv, 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); + SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); 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); + badarg3:SCM_WTA (3,obj); } break; case scm_tc7_bvect: @@ -1882,13 +1857,13 @@ scm_bit_count_star (v, kv, obj) } return SCM_MAKINUM (count); } +#undef FUNC_NAME -SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x); - -SCM -scm_bit_invert_x (v) - SCM v; +GUILE_PROC(scm_bit_invert_x, "bit-invert!", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_bit_invert_x { register long k; SCM_ASRTGO (SCM_NIMP (v), badarg1); @@ -1901,16 +1876,15 @@ scm_bit_invert_x (v) SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; break; default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x); + badarg1:SCM_WTA (1,v); } return SCM_UNSPECIFIED; } +#undef FUNC_NAME SCM -scm_istr2bve (str, len) - char *str; - long len; +scm_istr2bve (char *str, long len) { SCM v = scm_make_uve (len, SCM_BOOL_T); long *data = (long *) SCM_VELTS (v); @@ -1940,13 +1914,8 @@ scm_istr2bve (str, len) -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; +ra2l (SCM ra,scm_sizet base,scm_sizet k) { register SCM res = SCM_EOL; register long inc = SCM_ARRAY_DIMS (ra)[k].inc; @@ -1974,11 +1943,10 @@ ra2l (ra, base, k) } -SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list); - -SCM -scm_array_to_list (v) - SCM v; +GUILE_PROC(scm_array_to_list, "array->list", 1, 0, 0, + (SCM v), +"") +#define FUNC_NAME s_scm_array_to_list { SCM res = SCM_EOL; register long k; @@ -1987,7 +1955,7 @@ scm_array_to_list (v) (v) { default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list); + badarg1:SCM_WTA (1,v); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); return ra2l (v, SCM_ARRAY_BASE (v), 0); @@ -2075,31 +2043,28 @@ scm_array_to_list (v) #endif /*SCM_FLOATS*/ } } +#undef FUNC_NAME 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); +static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k); -SCM -scm_list_to_uniform_array (ndim, prot, lst) - SCM ndim; - SCM prot; - SCM lst; +GUILE_PROC(scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, + (SCM ndim, SCM prot, SCM lst), +"") +#define FUNC_NAME s_scm_list_to_uniform_array { 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); + SCM_VALIDATE_INT_COPY(1,ndim,k); while (k--) { n = scm_ilength (row); - SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array); + SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME); shp = scm_cons (SCM_MAKINUM (n), shp); if (SCM_NIMP (row)) row = SCM_CAR (row); @@ -2122,16 +2087,13 @@ scm_list_to_uniform_array (ndim, prot, lst) if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) return ra; else - badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array); + badlst:scm_wta (lst, s_bad_ralst, FUNC_NAME); return SCM_BOOL_F; } +#undef FUNC_NAME static int -l2ra (lst, ra, base, k) - SCM lst; - SCM ra; - scm_sizet base; - scm_sizet k; +l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) { 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); @@ -2168,15 +2130,8 @@ l2ra (lst, ra, base, k) } -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; - scm_sizet j; - scm_sizet k; - SCM port; - scm_print_state *pstate; +rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate) { long inc = 1; long n = SCM_LENGTH (ra); @@ -2351,10 +2306,7 @@ tail: int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { SCM v = exp; scm_sizet base = 0; @@ -2450,11 +2402,10 @@ tail: return 1; } -SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); - -SCM -scm_array_prototype (ra) - SCM ra; +GUILE_PROC(scm_array_prototype, "array-prototype", 1, 0, 0, + (SCM ra), +"") +#define FUNC_NAME s_scm_array_prototype { int enclosed = 0; SCM_ASRTGO (SCM_NIMP (ra), badarg); @@ -2463,7 +2414,7 @@ loop: (ra) { default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype); + badarg:SCM_WTA (1,ra); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (ra), badarg); if (enclosed++) @@ -2501,23 +2452,18 @@ loop: #endif } } +#undef FUNC_NAME -static SCM markra SCM_P ((SCM ptr)); - static SCM -markra (ptr) - SCM ptr; +markra (SCM ptr) { return SCM_ARRAY_V (ptr); } -static scm_sizet freera SCM_P ((SCM ptr)); - static scm_sizet -freera (ptr) - SCM ptr; +freera (SCM ptr) { scm_must_free (SCM_CHARS (ptr)); return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); |