From f301dbf34a32e982f671b7b86ac39f3a880cac7b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Wed, 29 Dec 2004 18:21:55 +0000 Subject: [PATCH] * srfi-4.h (scm_i_proc_make_u8vector, scm_i_proc_make_s8vector, scm_i_proc_make_u16vector, scm_i_proc_make_s16vector, scm_i_proc_make_u32vector, scm_i_proc_make_s32vector, scm_i_proc_make_u64vector, scm_i_proc_make_s64vector, scm_i_proc_make_f32vector, scm_i_proc_make_f64vector, scm_i_proc_make_c32vector, scm_i_proc_make_c64vector, uvec_proc_vars): Removed. (scm_i_generalized_vector_creator): Removed. (scm_i_generalized_vector_type): New. * unif.h, unif.c (scm_typed_array_p, scm_make_array, scm_make_typed_array, scm_array_type, scm_list_to_array, scm_list_to_typed_array, scm_is_array, scm_is_typed_array): New. (scm_array_creator): Removed. (scm_array_p): Deprecated second PROT argument. (scm_dimensions_to_uniform_array, scm_list_to_uniform_array): Deprecated, reimplemented in terms of scm_make_typed_array and scm_list_to_typed_array. (scm_i_proc_make_vector, scm_i_proc_make_string, scm_i_proc_make_bitvector): Removed. (type_creator_table, init_type_creator_table, type_to_creator, make_typed_vector): New. (scm_i_convert_old_prototype): Removed. (prototype_to_type): New. (scm_make_uve): Deprecated, reimplemented using make_typed_vector. (scm_array_dimensions): Use scm_list_1 instead of scm_cons for minor added clarity. (scm_make_shared_array, scm_ra2contig): Use make_typed_vector instead of scm_make_uve. (tag_creator_table, scm_i_tag_to_creator): Removed. (tag_to_type): New. (scm_i_read_array): Use scm_list_to_typed_array instead of scm_list_to_uniform_array. --- libguile/srfi-4.c | 58 +----- libguile/srfi-4.h | 15 +- libguile/unif.c | 457 +++++++++++++++++++++++++--------------------- libguile/unif.h | 13 +- 4 files changed, 266 insertions(+), 277 deletions(-) diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index f3a75c78c..32b1b23d2 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -449,32 +449,20 @@ coerce_to_uvec (int type, SCM obj) scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector"); } -static SCM *uvec_proc_vars[12] = { - &scm_i_proc_make_u8vector, - &scm_i_proc_make_s8vector, - &scm_i_proc_make_u16vector, - &scm_i_proc_make_s16vector, - &scm_i_proc_make_u32vector, - &scm_i_proc_make_s32vector, - &scm_i_proc_make_u64vector, - &scm_i_proc_make_s64vector, - &scm_i_proc_make_f32vector, - &scm_i_proc_make_f64vector, - &scm_i_proc_make_c32vector, - &scm_i_proc_make_c64vector -}; +SCM_SYMBOL (scm_sym_a, "a"); +SCM_SYMBOL (scm_sym_b, "b"); SCM -scm_i_generalized_vector_creator (SCM v) +scm_i_generalized_vector_type (SCM v) { if (scm_is_vector (v)) - return scm_i_proc_make_vector; + return SCM_BOOL_T; else if (scm_is_string (v)) - return scm_i_proc_make_string; + return scm_sym_a; else if (scm_is_bitvector (v)) - return scm_i_proc_make_bitvector; + return scm_sym_b; else if (scm_is_uniform_vector (v)) - return *(uvec_proc_vars[SCM_UVEC_TYPE(v)]); + return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]); else return SCM_BOOL_F; } @@ -931,21 +919,6 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define CTYPE double #include "libguile/srfi-4.i.c" -SCM scm_i_proc_make_u8vector; -SCM scm_i_proc_make_s8vector; -SCM scm_i_proc_make_u16vector; -SCM scm_i_proc_make_s16vector; -SCM scm_i_proc_make_u32vector; -SCM scm_i_proc_make_s32vector; -SCM scm_i_proc_make_u64vector; -SCM scm_i_proc_make_s64vector; -SCM scm_i_proc_make_f32vector; -SCM scm_i_proc_make_f64vector; -SCM scm_i_proc_make_c32vector; -SCM scm_i_proc_make_c64vector; - -/* Create the smob type for homogeneous numeric vectors and install - the primitives. */ void scm_init_srfi_4 (void) { @@ -953,24 +926,9 @@ scm_init_srfi_4 (void) scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); scm_set_smob_free (scm_tc16_uvec, uvec_free); scm_set_smob_print (scm_tc16_uvec, uvec_print); + #include "libguile/srfi-4.x" -#define GETPROC(tag) \ - scm_i_proc_make_##tag##vector = \ - scm_variable_ref (scm_c_lookup ("make-"#tag"vector")) - - GETPROC (u8); - GETPROC (s8); - GETPROC (u16); - GETPROC (s16); - GETPROC (u32); - GETPROC (s32); - GETPROC (u64); - GETPROC (s64); - GETPROC (f32); - GETPROC (f64); - GETPROC (c32); - GETPROC (c64); } /* End of srfi-4.c. */ diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 503e12292..1733a7f5c 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -208,25 +208,12 @@ SCM_API SCM scm_any_to_c64vector (SCM obj); SCM_API const double *scm_c64vector_elements (SCM uvec); SCM_API double *scm_c64vector_writable_elements (SCM uvec); -SCM_API SCM scm_i_generalized_vector_creator (SCM uvec); +SCM_API SCM scm_i_generalized_vector_type (SCM vec); SCM_API const char *scm_i_uniform_vector_tag (SCM uvec); /* deprecated */ SCM_API size_t scm_uniform_element_size (SCM obj); -SCM_API SCM scm_i_proc_make_u8vector; -SCM_API SCM scm_i_proc_make_s8vector; -SCM_API SCM scm_i_proc_make_u16vector; -SCM_API SCM scm_i_proc_make_s16vector; -SCM_API SCM scm_i_proc_make_u32vector; -SCM_API SCM scm_i_proc_make_s32vector; -SCM_API SCM scm_i_proc_make_u64vector; -SCM_API SCM scm_i_proc_make_s64vector; -SCM_API SCM scm_i_proc_make_f32vector; -SCM_API SCM scm_i_proc_make_f64vector; -SCM_API SCM scm_i_proc_make_c32vector; -SCM_API SCM scm_i_proc_make_c64vector; - SCM_API void scm_init_srfi_4 (void); #endif /* SCM_SRFI_4_H */ diff --git a/libguile/unif.c b/libguile/unif.c index a98348201..4de949c02 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -82,9 +82,61 @@ scm_t_bits scm_tc16_array; scm_t_bits scm_tc16_enclosed_array; -SCM scm_i_proc_make_vector; -SCM scm_i_proc_make_string; -SCM scm_i_proc_make_bitvector; +typedef SCM creator_proc (SCM len, SCM fill); + +struct { + char *type_name; + SCM type; + creator_proc *creator; +} type_creator_table[] = { + { "a", SCM_UNSPECIFIED, scm_make_string }, + { "b", SCM_UNSPECIFIED, scm_make_bitvector }, + { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, + { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, + { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, + { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, + { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, + { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, + { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, + { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, + { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, + { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, + { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, + { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, + { NULL } +}; + +static void +init_type_creator_table () +{ + int i; + for (i = 0; type_creator_table[i].type_name; i++) + { + SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); + type_creator_table[i].type = scm_permanent_object (sym); + } +} + +static creator_proc * +type_to_creator (SCM type) +{ + int i; + + if (scm_is_eq (type, SCM_BOOL_T)) + return scm_make_vector; + for (i = 0; type_creator_table[i].type_name; i++) + if (scm_is_eq (type, type_creator_table[i].type)) + return type_creator_table[i].creator; + + scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); +} + +static SCM +make_typed_vector (SCM type, size_t len) +{ + creator_proc *creator = type_to_creator (type); + return creator (scm_from_size_t (len), SCM_UNDEFINED); +} #if SCM_ENABLE_DEPRECATED @@ -92,46 +144,40 @@ SCM_SYMBOL (scm_sym_s, "s"); SCM_SYMBOL (scm_sym_l, "l"); static SCM -scm_i_convert_old_prototype (SCM proto) +prototype_to_type (SCM proto) { - SCM new_proto; - - /* All new 'prototypes' are creator procedures. - */ - if (scm_is_true (scm_procedure_p (proto))) - return proto; + const char *type_name; if (scm_is_eq (proto, SCM_BOOL_T)) - new_proto = scm_i_proc_make_bitvector; + type_name = "b"; else if (scm_is_eq (proto, SCM_MAKE_CHAR ('a'))) - new_proto = scm_i_proc_make_string; + type_name = "a"; else if (scm_is_eq (proto, SCM_MAKE_CHAR (0))) - new_proto = scm_i_proc_make_s8vector; + type_name = "s8"; else if (scm_is_eq (proto, scm_sym_s)) - new_proto = scm_i_proc_make_s16vector; + type_name = "s16"; else if (scm_is_true (scm_eqv_p (proto, scm_from_int (1)))) - new_proto = scm_i_proc_make_u32vector; + type_name = "u32"; else if (scm_is_true (scm_eqv_p (proto, scm_from_int (-1)))) - new_proto = scm_i_proc_make_s32vector; + type_name = "s32"; else if (scm_is_eq (proto, scm_sym_l)) - new_proto = scm_i_proc_make_s64vector; + type_name = "s64"; else if (scm_is_true (scm_eqv_p (proto, scm_from_double (1.0)))) - new_proto = scm_i_proc_make_f32vector; + type_name = "f32"; else if (scm_is_true (scm_eqv_p (proto, scm_divide (scm_from_int (1), - scm_from_int (3))))) - new_proto = scm_i_proc_make_f64vector; + scm_from_int (3))))) + type_name = "f64"; else if (scm_is_true (scm_eqv_p (proto, scm_c_make_rectangular (0, 1)))) - new_proto = scm_i_proc_make_c64vector; + type_name = "c64"; else if (scm_is_null (proto)) - new_proto = scm_i_proc_make_vector; + type_name = NULL; else - new_proto = proto; + type_name = NULL; - scm_c_issue_deprecation_warning - ("Using prototypes with arrays is deprecated. " - "Use creator functions instead."); - - return new_proto; + if (type_name) + return scm_from_locale_symbol (type_name); + else + return SCM_BOOL_T; } static SCM @@ -163,58 +209,98 @@ scm_i_get_old_prototype (SCM uvec) scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec)); } -#endif - SCM scm_make_uve (long k, SCM prot) #define FUNC_NAME "scm_make_uve" { - SCM res; -#if SCM_ENABLE_DEPRECATED - prot = scm_i_convert_old_prototype (prot); -#endif - res = scm_call_1 (prot, scm_from_long (k)); - if (!scm_is_generalized_vector (res)) - scm_wrong_type_arg_msg (NULL, 0, res, "generalized vector"); - return res; + scm_c_issue_deprecation_warning + ("`scm_make_uve' is deprecated, see the manual for alternatives."); + + return make_typed_vector (prototype_to_type (prot), k); } #undef FUNC_NAME -SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, - (SCM v, SCM prot), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not. The @var{prototype} argument is used with uniform arrays\n" - "and is described elsewhere.") -#define FUNC_NAME s_scm_array_p +#endif + +int +scm_is_array (SCM obj) { - if (SCM_ENCLOSED_ARRAYP (v)) + return (SCM_ENCLOSED_ARRAYP (obj) + || SCM_ARRAYP (obj) + || scm_is_generalized_vector (obj)); +} + +int +scm_is_typed_array (SCM obj, SCM type) +{ + if (SCM_ENCLOSED_ARRAYP (obj)) { - /* Enclosed arrays are arrays but are not created by any known - creator procedure. + /* Enclosed arrays are arrays but are not of any type. */ - if (SCM_UNBNDP (prot)) - return SCM_BOOL_T; - else - return SCM_BOOL_F; + return 0; } /* Get storage vector. */ - if (SCM_ARRAYP (v)) - v = SCM_ARRAY_V (v); + if (SCM_ARRAYP (obj)) + obj = SCM_ARRAY_V (obj); /* It must be a generalized vector (which includes vectors, strings, etc). */ - if (!scm_is_generalized_vector (v)) - return SCM_BOOL_F; + if (!scm_is_generalized_vector (obj)) + return 0; - if (SCM_UNBNDP (prot)) - return SCM_BOOL_T; + return scm_is_eq (type, scm_i_generalized_vector_type (obj)); +} #if SCM_ENABLE_DEPRECATED - prot = scm_i_convert_old_prototype (prot); -#endif - return scm_eq_p (prot, scm_i_generalized_vector_creator (v)); + +SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, + (SCM obj, SCM prot), + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not.") +#define FUNC_NAME s_scm_array_p +{ + if (!SCM_UNBNDP (prot)) + { + scm_c_issue_deprecation_warning + ("Using prototypes with `array?' is deprecated." + " Use `typed-array?' instead."); + + return scm_typed_array_p (obj, prototype_to_type (prot)); + } + else + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +#else /* !SCM_ENABLE_DEPRECATED */ + +/* We keep the old 2-argument C prototype for a while although the old + PROT argument is always ignored now. C code should probably use + scm_is_array or scm_is_typed_array anyway. +*/ + +SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, + (SCM obj, SCM unused), + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not.") +#define FUNC_NAME s_scm_array_p +{ + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +#endif /* !SCM_ENABLE_DEPRECATED */ + + +SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, + (SCM obj, SCM type), + "Return @code{#t} if the @var{obj} is an array of type\n" + "@var{type}, and @code{#f} if not.") +#define FUNC_NAME s_scm_typed_array_p +{ + return scm_from_bool (scm_is_typed_array (obj, type)); } #undef FUNC_NAME @@ -245,7 +331,7 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, #define FUNC_NAME s_scm_array_dimensions { if (scm_is_generalized_vector (ra)) - return scm_cons (scm_generalized_vector_length (ra), SCM_EOL); + return scm_list_1 (scm_generalized_vector_length (ra)); if (SCM_ARRAYP (ra) || SCM_ENCLOSED_ARRAYP (ra)) { @@ -416,35 +502,18 @@ scm_shap2ra (SCM args, const char *what) return ra; } -SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, - (SCM dims, SCM prot, SCM fill), - "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n" - "Create and return a uniform array or vector of type\n" - "corresponding to @var{prototype} with dimensions @var{dims} or\n" - "length @var{length}. If @var{fill} is supplied, it's used to\n" - "fill the array, otherwise @var{prototype} is used.") -#define FUNC_NAME s_scm_dimensions_to_uniform_array +SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, + (SCM type, SCM fill, SCM bounds), + "Create and return an array of type @var{type}.") +#define FUNC_NAME s_scm_make_typed_array { - size_t k; - unsigned long rlen = 1; + size_t k, rlen = 1; scm_t_array_dim *s; + creator_proc *creator; SCM ra; - if (scm_is_integer (dims)) - { - SCM answer = scm_make_uve (scm_to_long (dims), prot); - if (!SCM_UNBNDP (fill)) - scm_array_fill_x (answer, fill); - else if (scm_is_symbol (prot) || scm_is_eq (prot, SCM_MAKE_CHAR (0))) - scm_array_fill_x (answer, scm_from_int (0)); - else if (scm_is_false (scm_procedure_p (prot))) - scm_array_fill_x (answer, prot); - return answer; - } - - SCM_ASSERT (scm_is_null (dims) || scm_is_pair (dims), - dims, SCM_ARG1, FUNC_NAME); - ra = scm_shap2ra (dims, FUNC_NAME); + creator = type_to_creator (type); + ra = scm_shap2ra (bounds, FUNC_NAME); SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); s = SCM_ARRAY_DIMS (ra); k = SCM_ARRAY_NDIM (ra); @@ -452,18 +521,14 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, while (k--) { s[k].inc = rlen; - SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd); + SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd); rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; } - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); + if (scm_is_eq (fill, SCM_BOOL_F) && !scm_is_eq (type, SCM_BOOL_T)) + fill = SCM_UNDEFINED; - if (!SCM_UNBNDP (fill)) - scm_array_fill_x (ra, fill); - else if (scm_is_symbol (prot) || scm_is_eq (prot, SCM_MAKE_CHAR (0))) - scm_array_fill_x (ra, scm_from_int (0)); - else if (scm_is_false (scm_procedure_p (prot))) - scm_array_fill_x (ra, prot); + SCM_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill); if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) @@ -472,6 +537,37 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, } #undef FUNC_NAME +SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, + (SCM fill, SCM bounds), + "Create and return an array.") +#define FUNC_NAME s_scm_make_array +{ + return scm_make_typed_array (SCM_BOOL_T, fill, bounds); +} +#undef FUNC_NAME + +#if SCM_ENABLE_DEPRECATED + +SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, + (SCM dims, SCM prot, SCM fill), + "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n" + "Create and return a uniform array or vector of type\n" + "corresponding to @var{prototype} with dimensions @var{dims} or\n" + "length @var{length}. If @var{fill} is supplied, it's used to\n" + "fill the array, otherwise @var{prototype} is used.") +#define FUNC_NAME s_scm_dimensions_to_uniform_array +{ + scm_c_issue_deprecation_warning + ("`dimensions->uniform-array' is deprecated. " + "Use `make-typed-array' instead."); + + if (scm_is_integer (dims)) + dims = scm_list_1 (dims); + return scm_make_typed_array (prototype_to_type (prot), fill, dims); +} +#undef FUNC_NAME + +#endif void scm_ra_set_contp (SCM ra) @@ -556,9 +652,9 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (s[k].ubnd < s[k].lbnd) { if (1 == SCM_ARRAY_NDIM (ra)) - ra = scm_make_uve (0L, scm_array_creator (ra)); + ra = make_typed_vector (scm_array_type (ra), 0); else - SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_creator (ra)); + SCM_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); return ra; } } @@ -616,7 +712,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) - return scm_make_uve (0L, scm_array_creator (ra)); + return make_typed_vector (scm_array_type (ra), 0); } scm_ra_set_contp (ra); return ra; @@ -1070,7 +1166,7 @@ scm_ra2contig (SCM ra, int copy) SCM_ARRAY_DIMS (ret)[k].inc = inc; inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; } - SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_creator (ra)); + SCM_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc); if (copy) scm_array_copy_x (ra, ret); return ret; @@ -1872,20 +1968,17 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k); -SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, - (SCM ndim, SCM prot, SCM lst), - "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n" - "Return a uniform array of the type indicated by prototype\n" - "@var{prot} with elements the same as those of @var{lst}.\n" - "Elements must be of the appropriate type, no coercions are\n" - "done.\n" +SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, + (SCM type, SCM ndim, SCM lst), + "Return an array of the type @var{type}\n" + "with elements the same as those of @var{lst}.\n" "\n" "The argument @var{ndim} determines the number of dimensions\n" "of the array. It is either an exact integer, giving the\n" "number directly, or a list of exact integers, whose length\n" "specifies the number of dimensions and each element is the\n" "lower index bound of its dimension.") -#define FUNC_NAME s_scm_list_to_uniform_array +#define FUNC_NAME s_scm_list_to_typed_array { SCM shape, row; SCM ra; @@ -1920,8 +2013,7 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } } - ra = scm_dimensions_to_uniform_array (scm_reverse_x (shape, SCM_EOL), prot, - SCM_UNDEFINED); + ra = scm_make_typed_array (type, SCM_BOOL_F, scm_reverse_x (shape, SCM_EOL)); if (scm_is_null (shape)) { @@ -1944,6 +2036,15 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, + (SCM ndim, SCM lst), + "Return an array with elements the same as those of @var{lst}.") +#define FUNC_NAME s_scm_list_to_array +{ + return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); +} +#undef FUNC_NAME + static int l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) { @@ -1981,6 +2082,27 @@ l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k) return ok; } +#if SCM_ENABLE_DEPRECATED + +SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, + (SCM ndim, SCM prot, SCM lst), + "Return a uniform array of the type indicated by prototype\n" + "@var{prot} with elements the same as those of @var{lst}.\n" + "Elements must be of the appropriate type, no coercions are\n" + "done.\n" + "\n" + "The argument @var{ndim} determines the number of dimensions\n" + "of the array. It is either an exact integer, giving the\n" + "number directly, or a list of exact integers, whose length\n" + "specifies the number of dimensions and each element is the\n" + "lower index bound of its dimension.") +#define FUNC_NAME s_scm_list_to_uniform_array +{ + return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst); +} +#undef FUNC_NAME + +#endif /* Print dimension DIM of ARRAY. */ @@ -2011,46 +2133,9 @@ scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, return 1; } -/* Print an array. (Only for strict arrays, not for strings, uniform - vectors, vectors and other stuff that can masquerade as an array.) +/* Print an array. (Only for strict arrays, not for generalized vectors.) */ -/* The array tag is generally of the form - * - * #<@lower><@lower>... - * - * is a positive integer in decimal giving the rank of the - * array. It is omitted when the rank is 1 and the array is - * non-shared and has zero-origin. For shared arrays and for a - * non-zero origin, the rank is always printed even when it is 1 to - * dinstinguish them from ordinary vectors. - * - * is the tag for a uniform (or homogenous) numeric vector, - * like u8, s16, etc, as defined by SRFI-4. It is omitted when the - * array is not uniform. - * - * <@lower> is a 'at' sign followed by a integer in decimal giving the - * lower bound of a dimension. There is one <@lower> for each - * dimension. When all lower bounds are zero, all <@lower> are - * omitted. - * - * Thus, - * - * #(1 2 3) is non-uniform array of rank 1 with lower bound 0 in - * dimension 0. (I.e., a regular vector.) - * - * #@2(1 2 3) is non-uniform array of rank 1 with lower bound 2 in - * dimension 0. - * - * #2((1 2 3) (4 5 6)) is a non-uniform array of rank 2; a 3x3 - * matrix with index ranges 0..2 and 0..2. - * - * #u32(0 1 2) is a uniform u8 array of rank 1. - * - * #2u32@2@3((1 2) (2 3)) is a uniform u8 array of rank 2 with index - * ranges 2..3 and 3..4. - */ - static int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { @@ -2106,97 +2191,56 @@ scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) C is the first character read after the '#'. */ -typedef struct { - const char *tag; - SCM *creator_var; -} tag_creator; - -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 }, - { "s16", &scm_i_proc_make_s16vector }, - { "u32", &scm_i_proc_make_u32vector }, - { "s32", &scm_i_proc_make_s32vector }, - { "u64", &scm_i_proc_make_u64vector }, - { "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_creator (const char *tag, SCM port) +tag_to_type (const char *tag, SCM port) { - tag_creator *tp; - - for (tp = tag_creator_table; tp->tag; tp++) - if (!strcmp (tp->tag, tag)) - return *(tp->creator_var); - #if SCM_ENABLE_DEPRECATED { - /* Recognize the old syntax, producing the old prototypes. + /* Recognize the old syntax. */ - SCM proto = SCM_EOL; const char *instead; switch (tag[0]) { case 'u': - proto = scm_from_int (1); instead = "u32"; break; case 'e': - proto = scm_from_int (-1); instead = "s32"; break; case 's': - proto = scm_from_double (1.0); instead = "f32"; break; case 'i': - proto = scm_divide (scm_from_int (1), scm_from_int (3)); instead = "f64"; break; case 'y': - proto = SCM_MAKE_CHAR (0); instead = "s8"; break; case 'h': - proto = scm_from_locale_symbol ("s"); instead = "s16"; break; case 'l': - proto = scm_from_locale_symbol ("l"); instead = "s64"; break; case 'c': - proto = scm_c_make_rectangular (0.0, 1.0); instead = "c64"; break; default: - instead = "???"; + instead = NULL; break; } - if (!scm_is_eq (proto, SCM_EOL) && tag[1] == '\0') + + if (instead && tag[1] == '\0') { scm_c_issue_deprecation_warning_fmt ("The tag '%c' is deprecated for uniform vectors. " "Use '%s' instead.", tag[0], instead); - return proto; + return scm_from_locale_symbol (instead); } } #endif - scm_i_input_error (NULL, port, - "unrecognized uniform array tag: ~a", - scm_list_1 (scm_from_locale_string (tag))); - return SCM_BOOL_F; + return scm_from_locale_symbol (tag); } SCM @@ -2305,9 +2349,9 @@ scm_i_read_array (SCM port, int c) SCM_EOL); /* Construct array. */ - return scm_list_to_uniform_array (lower_bounds, - scm_i_tag_to_creator (tag, port), - elements); + return scm_list_to_typed_array (tag_to_type (tag, port), + lower_bounds, + elements); } int @@ -2317,17 +2361,15 @@ scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) return 1; } -SCM_DEFINE (scm_array_creator, "array-creator", 1, 0, 0, +SCM_DEFINE (scm_array_type, "array-type", 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-array*}.") -#define FUNC_NAME s_scm_array_creator + "") +#define FUNC_NAME s_scm_array_type { if (SCM_ARRAYP (ra)) - return scm_i_generalized_vector_creator (SCM_ARRAY_V (ra)); + return scm_i_generalized_vector_type (SCM_ARRAY_V (ra)); else if (scm_is_generalized_vector (ra)) - return scm_i_generalized_vector_creator (ra); + return scm_i_generalized_vector_type (ra); else if (SCM_ENCLOSED_ARRAYP (ra)) scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); else @@ -2363,7 +2405,6 @@ array_mark (SCM ptr) return SCM_ARRAY_V (ptr); } - static size_t array_free (SCM ptr) { @@ -2396,12 +2437,10 @@ scm_init_unif () scm_set_smob_print (scm_tc16_bitvector, bitvector_print); scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); + init_type_creator_table (); + #include "libguile/unif.x" - scm_i_proc_make_vector = scm_variable_ref (scm_c_lookup ("make-vector")); - scm_i_proc_make_string = scm_variable_ref (scm_c_lookup ("make-string")); - scm_i_proc_make_bitvector = - scm_variable_ref (scm_c_lookup ("make-bitvector")); } /* diff --git a/libguile/unif.h b/libguile/unif.h index 5acd5e599..83325f7d6 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -76,6 +76,9 @@ SCM_API scm_t_bits scm_tc16_enclosed_array; #define SCM_ARRAY_DIMS(a) ((scm_t_array_dim *)((char *) SCM_ARRAY_MEM (a) + sizeof (scm_t_array))) SCM_API SCM scm_array_p (SCM v, SCM prot); +SCM_API SCM scm_typed_array_p (SCM v, SCM type); +SCM_API SCM scm_make_array (SCM fill, SCM bounds); +SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); SCM_API SCM scm_array_rank (SCM ra); SCM_API SCM scm_array_dimensions (SCM ra); SCM_API SCM scm_shared_array_root (SCM ra); @@ -93,7 +96,12 @@ SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd, SCM start, SCM end); SCM_API SCM scm_array_to_list (SCM v); -SCM_API SCM scm_array_creator (SCM ra); +SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); +SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); +SCM_API SCM scm_array_type (SCM ra); + +SCM_API int scm_is_array (SCM obj); +SCM_API int scm_is_typed_array (SCM obj, SCM type); SCM_API SCM scm_i_read_array (SCM port, int c); @@ -143,9 +151,6 @@ SCM_API SCM scm_shap2ra (SCM args, const char *what); SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); SCM_API SCM scm_ra2contig (SCM ra, int copy); -SCM_API SCM scm_i_proc_make_vector; -SCM_API SCM scm_i_proc_make_string; -SCM_API SCM scm_i_proc_make_bitvector; SCM_API SCM scm_i_cvref (SCM v, size_t p, int enclosed); SCM_API void scm_init_unif (void); -- 2.20.1