* 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

@@ -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_SYMBOL (scm_sym_a, "a");
-  &scm_i_proc_make_u8vector,
+SCM_SYMBOL (scm_sym_b, "b");
-  &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
-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.  */

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 */

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;
+typedef SCM creator_proc (SCM len, SCM fill);
-SCM scm_i_proc_make_string;
+
-SCM scm_i_proc_make_bitvector;
+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;
+  const char *type_name;
-
-  /* All new 'prototypes' are creator procedures. 
-   */
-  if (scm_is_true (scm_procedure_p (proto)))
-    return proto;
 
   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)))))
+						      scm_from_int (3)))))
-    new_proto = scm_i_proc_make_f64vector;
+    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
+  if (type_name)
-    ("Using prototypes with arrays is deprecated.  "
+    return scm_from_locale_symbol (type_name);
-     "Use creator functions instead.");
+  else
-
+    return SCM_BOOL_T;
-  return new_proto;
 }
 
 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;
+  scm_c_issue_deprecation_warning
-#if SCM_ENABLE_DEPRECATED
+    ("`scm_make_uve' is deprecated, see the manual for alternatives.");
-  prot = scm_i_convert_old_prototype (prot);
+
-#endif
+  return make_typed_vector (prototype_to_type (prot), k);
-  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;
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
+#endif
-           (SCM v, SCM prot),
+
-	    "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
+int
-	    "not.  The @var{prototype} argument is used with uniform arrays\n"
+scm_is_array (SCM obj)
-	    "and is described elsewhere.")
-#define FUNC_NAME s_scm_array_p
 {
-  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
+      /* Enclosed arrays are arrays but are not of any type.
-	 creator procedure.
       */
-      if (SCM_UNBNDP (prot))
+      return 0;
-	return SCM_BOOL_T;
-      else
-	return SCM_BOOL_F;
     }
 
   /* Get storage vector. 
    */
-  if (SCM_ARRAYP (v))
+  if (SCM_ARRAYP (obj))
-    v = SCM_ARRAY_V (v);
+    obj = SCM_ARRAY_V (obj);
 
   /* It must be a generalized vector (which includes vectors, strings, etc).
    */
-  if (!scm_is_generalized_vector (v))
+  if (!scm_is_generalized_vector (obj))
-    return SCM_BOOL_F;
+    return 0;
 
-  if (SCM_UNBNDP (prot))
+  return scm_is_eq (type, scm_i_generalized_vector_type (obj));
-    return SCM_BOOL_T;
+}
 
 #if SCM_ENABLE_DEPRECATED
-  prot = scm_i_convert_old_prototype (prot);
+
-#endif
+SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
-  return scm_eq_p (prot, scm_i_generalized_vector_creator (v));
+           (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,6 +502,52 @@ scm_shap2ra (SCM args, const char *what)
   return ra;
 }
 
+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, rlen = 1;
+  scm_t_array_dim *s;
+  creator_proc *creator;
+  SCM ra;
+  
+  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);
+
+  while (k--)
+    {
+      s[k].inc = rlen;
+      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd);
+      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+    }
+
+  if (scm_is_eq (fill, SCM_BOOL_F) && !scm_is_eq (type, SCM_BOOL_T))
+    fill = SCM_UNDEFINED;
+
+  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))
+      return SCM_ARRAY_V (ra);
+  return ra;
+}
+#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"
@@ -425,53 +557,17 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
 	    "fill the array, otherwise @var{prototype} is used.")
 #define FUNC_NAME s_scm_dimensions_to_uniform_array
 {
-  size_t k;
+  scm_c_issue_deprecation_warning
-  unsigned long rlen = 1;
+    ("`dimensions->uniform-array' is deprecated.  "
-  scm_t_array_dim *s;
+     "Use `make-typed-array' instead.");
-  SCM ra;
+
-  
   if (scm_is_integer (dims))
-    {
+    dims = scm_list_1 (dims);
-      SCM answer = scm_make_uve (scm_to_long (dims), prot);
+  return scm_make_typed_array (prototype_to_type (prot), fill, dims);
-      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);
-  SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-  s = SCM_ARRAY_DIMS (ra);
-  k = SCM_ARRAY_NDIM (ra);
-
-  while (k--)
-    {
-      s[k].inc = rlen;
-      SCM_ASSERT_RANGE (1, dims, 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_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);
-
-  if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
-    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
-      return SCM_ARRAY_V (ra);
-  return ra;
 }
 #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_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
-           (SCM ndim, SCM prot, SCM lst),
+           (SCM type, SCM ndim, SCM lst),
-	    "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
+	    "Return an array of the type @var{type}\n"
-	    "Return a uniform array of the type indicated by prototype\n"
+	    "with elements the same as those of @var{lst}.\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
+#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,
+  ra = scm_make_typed_array (type, SCM_BOOL_F, scm_reverse_x (shape, SCM_EOL));
-					SCM_UNDEFINED);
 
   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
+/* Print an array.  (Only for strict arrays, not for generalized vectors.)
-   vectors, vectors and other stuff that can masquerade as an array.)
 */
 
-/* The array tag is generally of the form
- *
- *   #<rank><unif><@lower><@lower>...
- *
- * <rank> 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.
- *
- * <unif> 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,
+  return scm_from_locale_symbol (tag);
-		     "unrecognized uniform array tag: ~a",
-		     scm_list_1 (scm_from_locale_string (tag)));
-  return SCM_BOOL_F;
 }
 
 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,
+  return scm_list_to_typed_array (tag_to_type (tag, port),
-				    scm_i_tag_to_creator (tag, port),
+				  lower_bounds,
-				    elements);
+				  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"
+#define FUNC_NAME s_scm_array_type
-	    "@code{make-array*}.")
-#define FUNC_NAME s_scm_array_creator
 {
   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"));
 }
 
 /*

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);