diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-11-12 18:55:25 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-11-12 18:55:25 +0000 |
commit | 02339e5b9b0b93c4181991b259cf38d71066a5dd (patch) | |
tree | d152b6c9c9d0f31f4e1c5859bcd44c4d4baabe33 /libguile/unif.c | |
parent | 4049959855462b48da4a4e1fdd9aafd3cc20fd1a (diff) | |
download | guile-02339e5b9b0b93c4181991b259cf38d71066a5dd.tar.gz |
(scm_tc16_enclosed_array, SCM_ENCLOSED_ARRAYP):
New.
(exactly_one_third, singp): Removed.
(scm_array_p, scm_array_dimensions, scm_shared_array_root,
scm_shared_array_offset, scm_shared_array_increments): Handle
enclosed arrays explicitely.
(scm_array_rank): Likewise. Also, do not return zero for
non-arrays, signal an error instead since arrays with rank zero do
exist.
(scm_i_make_ra): New, for specifying the tag of the new array.
(scm_make_enclosed_array): Use it.
(scm_make_ra): Reimplemented in terms of scm_i_make_ra.
(scm_make_shared_array): Use scm_c_generalized_vector_length
instead of scm_uniform_vector_length.
(scm_array_in_bounds_p): Rewritten to be much cleaner.
(scm_i_cvref): New, doing the job of scm_cvref.
(scm_cvref): Use scm_i_cvref.
(scm_array_ref): Do not accept non-arrays when no indices are
given. Use scm_i_cvref to do the actual access.
("uniform-array-set1"): Do not register.
(scm_array_set_x, scm_uniform_array_read_x,
scm_uniform_array_write): Handle enclosed arrays explicitly.
(ra2l): Use scm_i_cvref instead of scm_uniform_vector_ref to also
handle enclosed arrays.
(scm_array_to_list): Handle enclosed arrays explicitly.
(rapr1): Removed.
(scm_i_print_array_dimension): Use scm_i_cvref to also handle
enclosed arrays.
(scm_i_print_enclosed_array): New.
(tag_proto_table, tag_creator_table): Renamed former to latter.
Added "a" and "b" for strings and bitvectors, resp.
(scm_i_tag_to_prototype, scm_i_tag_to_creator): Renamed former to
latter. Tag "a" is in the table now, no need to handle it as a
legacy tag.
(scm_raprin1): Just call scm_iprin1.
(scm_array_creator, scm_array_prototype): Handle enclosed arrays
explicitly.
(scm_init_unif): Initialize scm_tc16_enclosed_array smob.
Use scm_i_print_array as printer for scm_tc16_array.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 519 |
1 files changed, 188 insertions, 331 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index 5e96dfdec..e50b7267d 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -80,25 +80,7 @@ */ scm_t_bits scm_tc16_array; -static SCM exactly_one_third; - -#if 0 -/* Silly function used not to modify the semantics of the silly - * prototype system in order to be backward compatible. - */ -static int -singp (SCM obj) -{ - if (!SCM_REALP (obj)) - return 0; - else - { - double x = SCM_REAL_VALUE (obj); - float fx = x; - return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x); - } -} -#endif +scm_t_bits scm_tc16_enclosed_array; SCM scm_i_proc_make_vector; SCM scm_i_proc_make_string; @@ -205,26 +187,28 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, "and is described elsewhere.") #define FUNC_NAME s_scm_array_p { - int nprot = SCM_UNBNDP (prot); - int enclosed = 0; - - /* Get storage vector. - */ - while (SCM_ARRAYP (v)) + if (SCM_ENCLOSED_ARRAYP (v)) { - if (nprot) + /* Enclosed arrays are arrays but are not created by any known + creator procedure. + */ + if (SCM_UNBNDP (prot)) return SCM_BOOL_T; - if (enclosed++) + else return SCM_BOOL_F; - v = SCM_ARRAY_V (v); } + /* Get storage vector. + */ + if (SCM_ARRAYP (v)) + v = SCM_ARRAY_V (v); + /* It must be a generalized vector (which includes vectors, strings, etc). */ if (!scm_is_generalized_vector (v)) return SCM_BOOL_F; - if (nprot) + if (SCM_UNBNDP (prot)) return SCM_BOOL_T; #if SCM_ENABLE_DEPRECATED @@ -236,25 +220,24 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM ra), - "Return the number of dimensions of @var{obj}. If @var{obj} is\n" - "not an array, @code{0} is returned.") + (SCM array), + "Return the number of dimensions of the array @var{array.}\n") #define FUNC_NAME s_scm_array_rank { - if (scm_is_generalized_vector (ra)) + if (scm_is_generalized_vector (array)) return scm_from_int (1); - if (SCM_ARRAYP (ra)) - return scm_from_size_t (SCM_ARRAY_NDIM (ra)); + if (SCM_ARRAYP (array) || SCM_ENCLOSED_ARRAYP (array)) + return scm_from_size_t (SCM_ARRAY_NDIM (array)); - return scm_from_int (0); + scm_wrong_type_arg_msg (NULL, 0, array, "array"); } #undef FUNC_NAME SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, (SCM ra), - "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n" + "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" "elements with a @code{0} minimum with one greater than the maximum. So:\n" "@lisp\n" "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" @@ -264,7 +247,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, if (scm_is_generalized_vector (ra)) return scm_cons (scm_generalized_vector_length (ra), SCM_EOL); - if (SCM_ARRAYP (ra)) + if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra)) { SCM res = SCM_EOL; size_t k; @@ -292,7 +275,8 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, "Return the root vector of a shared array.") #define FUNC_NAME s_scm_shared_array_root { - SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, + SCM_ARG1, FUNC_NAME); return SCM_ARRAY_V (ra); } #undef FUNC_NAME @@ -303,7 +287,8 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, "Return the root vector index of the first element in the array.") #define FUNC_NAME s_scm_shared_array_offset { - SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, + SCM_ARG1, FUNC_NAME); return scm_from_int (SCM_ARRAY_BASE (ra)); } #undef FUNC_NAME @@ -317,7 +302,9 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, SCM res = SCM_EOL; size_t k; scm_t_array_dim *s; - SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME); + + SCM_ASSERT (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra), ra, + SCM_ARG1, FUNC_NAME); k = SCM_ARRAY_NDIM (ra); s = SCM_ARRAY_DIMS (ra); while (k--) @@ -332,13 +319,13 @@ static char s_bad_ind[] = "Bad scm_array index"; long scm_aind (SCM ra, SCM args, const char *what) -#define FUNC_NAME what { SCM ind; register long j; register unsigned long pos = SCM_ARRAY_BASE (ra); register unsigned long k = SCM_ARRAY_NDIM (ra); scm_t_array_dim *s = SCM_ARRAY_DIMS (ra); + if (scm_is_integer (args)) { if (k != 1) @@ -363,27 +350,32 @@ scm_aind (SCM ra, SCM args, const char *what) return pos; } -#undef FUNC_NAME -SCM -scm_make_ra (int ndim) +static SCM +scm_i_make_ra (int ndim, scm_t_bits tag) { SCM ra; - SCM_DEFER_INTS; - SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array, + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag, scm_gc_malloc ((sizeof (scm_t_array) + ndim * sizeof (scm_t_array_dim)), "array")); - SCM_ARRAY_V (ra) = scm_nullvect; - SCM_ALLOW_INTS; + SCM_ARRAY_V (ra) = SCM_BOOL_F; return ra; } +SCM +scm_make_ra (int ndim) +{ + return scm_i_make_ra (ndim, scm_tc16_array); +} + + static char s_bad_spec[] = "Bad scm_array dimension"; -/* Increments will still need to be set. */ +/* Increments will still need to be set. */ + SCM scm_shap2ra (SCM args, const char *what) { @@ -484,6 +476,9 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, void scm_ra_set_contp (SCM ra) { + /* XXX - correct? one-dimensional arrays are always 'contiguous', + is that right? + */ size_t k = SCM_ARRAY_NDIM (ra); if (k) { @@ -551,7 +546,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, { SCM_ARRAY_V (ra) = oldra; old_min = 0; - old_max = scm_to_long (scm_uniform_vector_length (oldra)) - 1; + old_max = scm_c_generalized_vector_length (oldra) - 1; } inds = SCM_EOL; s = SCM_ARRAY_DIMS (ra); @@ -673,7 +668,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, return ra; } - if (SCM_ARRAYP (ra)) + if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra)) { vargs = scm_vector (args); if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra)) @@ -759,7 +754,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, SCM_VALIDATE_REST_ARGUMENT (axes); if (scm_is_null (axes)) - axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); + axes = scm_cons ((SCM_ARRAYP (ra) ? scm_from_size_t (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); ninr = scm_ilength (axes); if (ninr < 0) SCM_WRONG_NUM_ARGS (); @@ -788,7 +783,7 @@ SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, if (noutr < 0) SCM_WRONG_NUM_ARGS (); axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); - res = scm_make_ra (noutr); + res = scm_i_make_ra (noutr, scm_tc16_enclosed_array); 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)) @@ -825,69 +820,82 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, "@code{array-ref}.") #define FUNC_NAME s_scm_array_in_bounds_p { - SCM ind = SCM_EOL; - long pos = 0; - register size_t k; - register long j; - scm_t_array_dim *s; + SCM res = SCM_BOOL_T; SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_pair (args)) - { - ind = SCM_CAR (args); - args = SCM_CDR (args); - pos = scm_to_long (ind); - } - -tail: if (scm_is_generalized_vector (v)) { - size_t length = scm_c_generalized_vector_length (v); - SCM_ASRTGO (scm_is_null (args) && scm_is_integer (ind), wna); - return scm_from_bool (pos >= 0 && pos < length); + long ind; + + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + res = scm_from_bool (ind >= 0 + && ind < scm_c_generalized_vector_length (v)); } - - if (SCM_ARRAYP (v)) + else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v)) { - k = SCM_ARRAY_NDIM (v); - s = SCM_ARRAY_DIMS (v); - pos = SCM_ARRAY_BASE (v); - if (!k) + size_t k = SCM_ARRAY_NDIM (v); + scm_t_array_dim *s = SCM_ARRAY_DIMS (v); + + while (k > 0) { - SCM_ASRTGO (scm_is_null (ind), wna); - ind = SCM_INUM0; - } - else - while (!0) - { - j = scm_to_long (ind); - if (!(j >= (s->lbnd) && j <= (s->ubnd))) - { - SCM_ASRTGO (--k == scm_ilength (args), wna); - return SCM_BOOL_F; - } - pos += (j - s->lbnd) * (s->inc); - if (!(--k && SCM_NIMP (args))) - break; - ind = SCM_CAR (args); - args = SCM_CDR (args); - s++; - if (!scm_is_integer (ind)) - SCM_MISC_ERROR (s_bad_ind, SCM_EOL); - } - SCM_ASRTGO (0 == k, wna); - v = SCM_ARRAY_V (v); - goto tail; + long ind; - wna: - SCM_WRONG_NUM_ARGS (); + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + k -= 1; + + if (ind < s->lbnd || ind > s->ubnd) + { + res = SCM_BOOL_F; + /* We do not stop the checking after finding a violation + since we want to validate the type-correctness and + number of arguments in any case. + */ + } + } } + else + scm_wrong_type_arg_msg (NULL, 0, v, "array"); - scm_wrong_type_arg_msg (NULL, 0, v, "array"); + if (!scm_is_null (args)) + SCM_WRONG_NUM_ARGS (); + + return res; } #undef FUNC_NAME +static SCM +scm_i_cvref (SCM v, size_t pos, int enclosed) +{ + if (enclosed) + { + int k = SCM_ARRAY_NDIM (v); + SCM res = scm_make_ra (k); + SCM_ARRAY_V (res) = SCM_ARRAY_V (v); + SCM_ARRAY_BASE (res) = pos; + while (k--) + { + SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; + SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; + SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; + } + return res; + } + else + return scm_c_generalized_vector_ref (v, pos); +} + +SCM +scm_cvref (SCM v, unsigned long pos, SCM last) +{ + return scm_i_cvref (v, pos, 0); +} SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, (SCM v, SCM args), @@ -896,14 +904,11 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, #define FUNC_NAME s_scm_array_ref { long pos; + int enclosed = 0; - if (SCM_IMP (v)) - { - SCM_ASRTGO (scm_is_null (args), badarg); - return v; - } - else if (SCM_ARRAYP (v)) + if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v)) { + enclosed = SCM_ENCLOSED_ARRAYP (v); pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } @@ -922,26 +927,8 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, SCM_ASRTGO (pos >= 0 && pos < length, outrng); } - if (scm_is_generalized_vector (v)) - return scm_c_generalized_vector_ref (v, pos); - - if (SCM_ARRAYP (v)) - { /* enclosed */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } + return scm_i_cvref (v, pos, enclosed); - badarg: - scm_wrong_type_arg_msg (NULL, 0, v, "array"); wna: scm_wrong_num_args (NULL); outrng: @@ -949,39 +936,7 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, } #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.) */ - -SCM -scm_cvref (SCM v, unsigned long pos, SCM last) -{ - if (scm_is_generalized_vector (v)) - return scm_c_generalized_vector_ref (v, pos); - - if (SCM_ARRAYP (v)) - { /* enclosed scm_array */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } - - scm_wrong_type_arg_msg (NULL, 0, v, "array"); -} - -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_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, (SCM v, SCM obj, SCM args), "Set the element at the @code{(index1, index2)} element in @var{array} to\n" @@ -995,7 +950,9 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, pos = scm_aind (v, args, FUNC_NAME); v = SCM_ARRAY_V (v); } - else + else if (SCM_ENCLOSED_ARRAYP (v)) + scm_wrong_type_arg_msg (NULL, 0, v, "non-enclosed array"); + else if (scm_is_generalized_vector (v)) { size_t length; if (scm_is_pair (args)) @@ -1008,14 +965,11 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, length = scm_c_generalized_vector_length (v); SCM_ASRTGO (pos >= 0 && pos < length, outrng); } - - if (scm_is_generalized_vector (v)) - { - scm_c_generalized_vector_set_x (v, pos, obj); - return SCM_UNSPECIFIED; - } - - scm_wrong_type_arg_msg (NULL, 0, v, "array"); + else + scm_wrong_type_arg_msg (NULL, 0, v, "array"); + + scm_c_generalized_vector_set_x (v, pos, obj); + return SCM_UNSPECIFIED; outrng: scm_out_of_range (NULL, scm_from_long (pos)); @@ -1081,8 +1035,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1); return sra; } - - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + else if (SCM_ENCLOSED_ARRAYP (ra)) + scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } #undef FUNC_NAME @@ -1173,6 +1129,8 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_array_copy_x (cra, ura); return ans; } + else if (SCM_ENCLOSED_ARRAYP (ura)) + scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } @@ -1223,6 +1181,8 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, return ans; } + else if (SCM_ENCLOSED_ARRAYP (ura)) + scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); else scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } @@ -1841,9 +1801,11 @@ scm_istr2bve (SCM str) static SCM ra2l (SCM ra, unsigned long base, unsigned long k) { - register SCM res = SCM_EOL; - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register size_t i; + SCM res = SCM_EOL; + long inc = SCM_ARRAY_DIMS (ra)[k].inc; + size_t i; + int enclosed = SCM_ENCLOSED_ARRAYP (ra); + if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) return SCM_EOL; i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; @@ -1860,7 +1822,8 @@ ra2l (SCM ra, unsigned long base, unsigned long k) do { i -= inc; - res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), scm_from_size_t (i)), res); + res = scm_cons (scm_i_cvref (SCM_ARRAY_V (ra), i, enclosed), + res); } while (i != base); return res; @@ -1875,7 +1838,7 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, { if (scm_is_generalized_vector (v)) return scm_generalized_vector_to_list (v); - else if (SCM_ARRAYP (v)) + else if (SCM_ARRAYP (v) || SCM_ENCLOSED_ARRAYP (v)) return ra2l (v, SCM_ARRAY_BASE (v), 0); scm_wrong_type_arg_msg (NULL, 0, v, "array"); @@ -1995,96 +1958,11 @@ l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) } -static void -rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate) -{ - long inc = 1; - long n = (SCM_TYP7 (ra) == scm_tc7_smob - ? 0 - : scm_to_long (scm_uniform_vector_length (ra))); - int enclosed = 0; -tail: - switch SCM_TYP7 (ra) - { - case scm_tc7_smob: - if (enclosed++) - { - SCM_ARRAY_BASE (ra) = j; - if (n-- > 0) - scm_iprin1 (ra, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_putc (' ', port); - SCM_ARRAY_BASE (ra) = j; - scm_iprin1 (ra, port, pstate); - } - break; - } - if (k + 1 < SCM_ARRAY_NDIM (ra)) - { - long i; - inc = SCM_ARRAY_DIMS (ra)[k].inc; - for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) - { - scm_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_putc ('(', port); - rapr1 (ra, j, k + 1, port, pstate); - scm_putc (')', port); - } - break; - } - if (SCM_ARRAY_NDIM (ra) > 0) - { /* Could be zero-dimensional */ - inc = SCM_ARRAY_DIMS (ra)[k].inc; - n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); - } - else - n = 1; - ra = SCM_ARRAY_V (ra); - goto tail; - default: - /* scm_tc7_bvect and scm_tc7_llvect only? */ - if (n-- > 0) - scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_putc (' ', port); - scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); - } - break; - case scm_tc7_string: - { - const char *src; - src = scm_i_string_chars (ra); - if (n-- > 0) - scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate); - if (SCM_WRITINGP (pstate)) - for (j += inc; n-- > 0; j += inc) - { - scm_putc (' ', port); - scm_iprin1 (SCM_MAKE_CHAR (src[j]), port, pstate); - } - else - for (j += inc; n-- > 0; j += inc) - scm_putc (src[j], port); - scm_remember_upto_here_1 (ra); - } - break; - - } -} - /* Print dimension DIM of ARRAY. */ static int -scm_i_print_array_dimension (SCM array, int dim, int base, +scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, SCM port, scm_print_state *pstate) { scm_t_array_dim *dim_spec = SCM_ARRAY_DIMS (array) + dim; @@ -2092,22 +1970,13 @@ scm_i_print_array_dimension (SCM array, int dim, int base, scm_putc ('(', port); -#if 0 - scm_putc ('{', port); - scm_intprint (dim_spec->lbnd, 10, port); - scm_putc (':', port); - scm_intprint (dim_spec->ubnd, 10, port); - scm_putc (':', port); - scm_intprint (dim_spec->inc, 10, port); - scm_putc ('}', port); -#endif - for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) { if (dim < SCM_ARRAY_NDIM(array)-1) - scm_i_print_array_dimension (array, dim+1, base, port, pstate); + scm_i_print_array_dimension (array, dim+1, base, enclosed, + port, pstate); else - scm_iprin1 (scm_cvref (SCM_ARRAY_V (array), base, SCM_UNDEFINED), + scm_iprin1 (scm_i_cvref (SCM_ARRAY_V (array), base, enclosed), port, pstate); if (idx < dim_spec->ubnd) scm_putc (' ', port); @@ -2190,7 +2059,20 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) break; } - return scm_i_print_array_dimension (array, 0, base, port, pstate); + return scm_i_print_array_dimension (array, 0, base, 0, port, pstate); +} + +static int +scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) +{ + size_t base; + + scm_putc ('#', port); + base = SCM_ARRAY_BASE (array); + scm_puts ("<enclosed-array ", port); + scm_i_print_array_dimension (array, 0, base, 1, port, pstate); + scm_putc ('>', port); + return 1; } /* Read an array. This function can also read vectors and uniform @@ -2202,11 +2084,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) typedef struct { const char *tag; - SCM *proto_var; -} tag_proto; + SCM *creator_var; +} tag_creator; -static tag_proto tag_proto_table[] = { +static tag_creator tag_creator_table[] = { { "", &scm_i_proc_make_vector }, + { "a", &scm_i_proc_make_string }, + { "b", &scm_i_proc_make_bitvector }, { "u8", &scm_i_proc_make_u8vector }, { "s8", &scm_i_proc_make_s8vector }, { "u16", &scm_i_proc_make_u16vector }, @@ -2217,17 +2101,19 @@ static tag_proto tag_proto_table[] = { { "s64", &scm_i_proc_make_s64vector }, { "f32", &scm_i_proc_make_f32vector }, { "f64", &scm_i_proc_make_f64vector }, + { "c32", &scm_i_proc_make_c32vector }, + { "c64", &scm_i_proc_make_c64vector }, { NULL, NULL } }; static SCM -scm_i_tag_to_prototype (const char *tag, SCM port) +scm_i_tag_to_creator (const char *tag, SCM port) { - tag_proto *tp; + tag_creator *tp; - for (tp = tag_proto_table; tp->tag; tp++) + for (tp = tag_creator_table; tp->tag; tp++) if (!strcmp (tp->tag, tag)) - return *(tp->proto_var); + return *(tp->creator_var); #if SCM_ENABLE_DEPRECATED { @@ -2237,10 +2123,6 @@ scm_i_tag_to_prototype (const char *tag, SCM port) const char *instead; switch (tag[0]) { - case 'a': - proto = SCM_MAKE_CHAR ('a'); - instead = "???"; - break; case 'u': proto = scm_from_int (1); instead = "u32"; @@ -2400,56 +2282,32 @@ scm_i_read_array (SCM port, int c) /* Construct array. */ return scm_list_to_uniform_array (lower_bounds, - scm_i_tag_to_prototype (tag, port), + scm_i_tag_to_creator (tag, port), elements); } int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) { - SCM v = exp; - unsigned long base = 0; - long ndim; - - if (SCM_ARRAYP (exp) && !SCM_ARRAYP (SCM_ARRAY_V (exp))) - return scm_i_print_array (exp, port, pstate); - - scm_putc ('#', port); - ndim = SCM_ARRAY_NDIM (v); - base = SCM_ARRAY_BASE (v); - v = SCM_ARRAY_V (v); - scm_puts ("<enclosed-array ", port); - rapr1 (exp, base, 0, port, pstate); - scm_putc ('>', port); + scm_iprin1 (exp, port, pstate); return 1; } SCM_DEFINE (scm_array_creator, "array-creator", 1, 0, 0, (SCM ra), "Return a procedure that would produce an array of the same type\n" - "as @var{array}, if used as the @var{creator} with\n" - "@code{make-uniform-array}.") + "as @var{array} if used as the @var{creator} with\n" + "@code{make-array*}.") #define FUNC_NAME s_scm_array_creator { - int outer = 1; - SCM orig_ra = ra; - if (SCM_ARRAYP (ra)) - { - ra = SCM_ARRAY_V (ra); - outer = 0; - } - - if (scm_is_generalized_vector (ra)) + return scm_i_generalized_vector_creator (SCM_ARRAY_V (ra)); + else if (scm_is_generalized_vector (ra)) return scm_i_generalized_vector_creator (ra); - else if (SCM_ARRAYP (ra)) - scm_misc_error (NULL, "creator not known for enclosed array: ~a", - scm_list_1 (orig_ra)); - else if (outer) - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); + else if (SCM_ENCLOSED_ARRAYP (ra)) + scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); else - scm_misc_error (NULL, "creator not known for array content: ~a", - scm_list_1 (ra)); + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } #undef FUNC_NAME @@ -2462,18 +2320,12 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, "@code{make-uniform-array}.") #define FUNC_NAME s_scm_array_prototype { - int enclosed = 0; - - loop: if (SCM_ARRAYP (ra)) - { - if (enclosed++) - return SCM_UNSPECIFIED; - ra = SCM_ARRAY_V (ra); - goto loop; - } + return scm_i_get_old_prototype (SCM_ARRAY_V (ra)); else if (scm_is_generalized_vector (ra)) return scm_i_get_old_prototype (ra); + else if (SCM_ENCLOSED_ARRAYP (ra)) + return SCM_UNSPECIFIED; else scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } @@ -2504,10 +2356,15 @@ scm_init_unif () scm_tc16_array = scm_make_smob_type ("array", 0); scm_set_smob_mark (scm_tc16_array, array_mark); scm_set_smob_free (scm_tc16_array, array_free); - scm_set_smob_print (scm_tc16_array, scm_raprin1); + scm_set_smob_print (scm_tc16_array, scm_i_print_array); scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p); - exactly_one_third = scm_permanent_object (scm_divide (scm_from_int (1), - scm_from_int (3))); + + scm_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); + scm_set_smob_mark (scm_tc16_enclosed_array, array_mark); + scm_set_smob_free (scm_tc16_enclosed_array, array_free); + scm_set_smob_print (scm_tc16_enclosed_array, scm_i_print_enclosed_array); + scm_set_smob_equalp (scm_tc16_enclosed_array, scm_array_equal_p); + scm_add_feature ("array"); scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); |