(scm_make_u1vector): New, but only temporary.

(make_uve): Removed.
(scm_i_proc_make_vector, scm_i_proc_make_string,
scm_i_proc_make_u1vector): New.
(scm_init_unif): Initialize them.
(scm_i_convert_old_prototype): New.
(scm_make_uve): Use it to get the creator procedure.  Removed all
old code that created old-style uniform vectors.
(scm_array_p): Handle generic vectors.
(scm_dimensions_to_uniform_array): Do not fill new array with
prototype when that is a procedure.
(scm_list_to_uniform_array): Also accept a list of lower bounds as
the NDIM argument.
(scm_i_print_array): Print rank for shared or non-zero-origin
vectors.
(tag_proto_table, scm_i_tag_to_prototype, scm_i_read_array): New.
(scm_raprin1): Do not call scm_i_array_print for enclosed arrays,
which I do not understand yet.
(scm_array_prototype): Explicitely handle generic vectors.

libguile/unif.c

@@ -46,11 +46,14 @@
 #include "libguile/srfi-13.h"
 #include "libguile/srfi-4.h"
 #include "libguile/vectors.h"
+#include "libguile/list.h"
+#include "libguile/deprecation.h"
 
 #include "libguile/validate.h"
 #include "libguile/unif.h"
 #include "libguile/ramap.h"
 #include "libguile/print.h"
+#include "libguile/read.h"
 
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
@@ -63,7 +66,7 @@
 
 /* The set of uniform scm_vector types is:
  *  Vector of:		 Called:   Replaced by:
- * unsigned char	string     u8
+ * unsigned char	string
  * char			byvect     s8
  * boolean		bvect      
  * signed long		ivect      s32
@@ -94,72 +97,90 @@ singp (SCM obj)
     }
 }
 
-static SCM
+static SCM scm_i_proc_make_vector;
-make_uve (long type, long k, size_t size)
+static SCM scm_i_proc_make_string;
-#define FUNC_NAME "scm_make_uve"
+static SCM scm_i_proc_make_u1vector;
-{
-  SCM_ASSERT_RANGE (1, scm_from_long (k), k <= SCM_UVECTOR_MAX_LENGTH);
 
-  return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type),
+#if SCM_ENABLE_DEPRECATED
-		   (scm_t_bits) scm_gc_malloc (k * size, "vector"));
+
+SCM_SYMBOL (scm_sym_s, "s");
+SCM_SYMBOL (scm_sym_l, "l");
+
+SCM scm_make_u1vector (SCM len, SCM fill);
+
+SCM_DEFINE (scm_make_u1vector, "make-u1vector", 1, 1, 0,
+	    (SCM len, SCM fill),
+	    "...")
+#define FUNC_NAME s_scm_make_u1vector
+{
+  long k = scm_to_long (len);
+  if (k > 0)
+    {
+      long i;
+      SCM_ASSERT_RANGE (1, scm_from_long (k),
+			k <= SCM_BITVECTOR_MAX_LENGTH);
+      i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
+      return scm_cell (SCM_MAKE_BITVECTOR_TAG (k), 
+		       (scm_t_bits) scm_gc_malloc (i, "vector"));
+    }
+  else
+    return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
 }
 #undef FUNC_NAME
 
+static SCM
+scm_i_convert_old_prototype (SCM proto)
+{
+  SCM new_proto;
+
+  /* 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_u1vector;
+  else if (scm_is_eq (proto, SCM_MAKE_CHAR ('a')))
+    new_proto = scm_i_proc_make_string;
+  else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
+    new_proto = scm_i_proc_make_s8vector;
+  else if (scm_is_eq (proto, scm_sym_s))
+    new_proto = scm_i_proc_make_s16vector;
+  else if (scm_is_true (scm_eqv_p (proto, scm_from_int (1))))
+    new_proto = scm_i_proc_make_u32vector;
+  else if (scm_is_true (scm_eqv_p (proto, scm_from_int (-1))))
+    new_proto = scm_i_proc_make_s32vector;
+  else if (scm_is_eq (proto, scm_sym_l))
+    new_proto = scm_i_proc_make_s64vector;
+  else if (scm_is_true (scm_eqv_p (proto, scm_from_double (1.0))))
+    new_proto = scm_i_proc_make_f32vector;
+  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;
+  else if (scm_is_true (scm_eqv_p (proto, scm_c_make_rectangular (0, 1))))
+    new_proto = scm_i_proc_make_c64vector;
+  else if (scm_is_null (proto))
+    new_proto = scm_i_proc_make_vector;
+  else
+    new_proto = proto;
+
+  scm_c_issue_deprecation_warning
+    ("Using prototypes with arrays is deprecated.  "
+     "Use creator functions instead.");
+
+  return new_proto;
+}
+
+#endif
+
 SCM 
 scm_make_uve (long k, SCM prot)
 #define FUNC_NAME "scm_make_uve"
 {
-  if (scm_is_eq (prot, SCM_BOOL_T))
+#if SCM_ENABLE_DEPRECATED
-    {
+  prot = scm_i_convert_old_prototype (prot);
-      if (k > 0)
-	{
-	  long i;
-	  SCM_ASSERT_RANGE (1, scm_from_long (k),
-			    k <= SCM_BITVECTOR_MAX_LENGTH);
-	  i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
-	  return scm_cell (SCM_MAKE_BITVECTOR_TAG (k), 
-			   (scm_t_bits) scm_gc_malloc (i, "vector"));
-	}
-      else
-	return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
-    }
-  else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
-    return scm_make_s8vector (scm_from_long (k), SCM_UNDEFINED);
-  else if (SCM_CHARP (prot))
-    return scm_c_make_string (sizeof (char) * k, SCM_UNDEFINED);
-  else if (SCM_I_INUMP (prot))
-    return make_uve (SCM_I_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect,
-		     k,
-		     sizeof (long));
-  else if (SCM_FRACTIONP (prot))
-    {
-      if (scm_num_eq_p (exactly_one_third, prot))
-        goto dvect;
-    }
-  else if (scm_is_symbol (prot) && (1 == scm_i_symbol_length (prot)))
-    {
-      char s;
-
-      s = scm_i_symbol_chars (prot)[0];
-      if (s == 's')
-	return make_uve (scm_tc7_svect, k, sizeof (short));
-#if SCM_SIZEOF_LONG_LONG != 0
-      else if (s == 'l')
-	return make_uve (scm_tc7_llvect, k, sizeof (long long));
 #endif
-      else
+  return scm_call_2 (prot, scm_from_long (k), SCM_UNDEFINED);
-	return scm_c_make_vector (k, SCM_UNDEFINED);
-    }
-  else if (!SCM_INEXACTP (prot))
-    /* Huge non-unif vectors are NOT supported. */
-    /* no special scm_vector */
-    return scm_c_make_vector (k, SCM_UNDEFINED);
-  else if (singp (prot))
-    return make_uve (scm_tc7_fvect, k, sizeof (float));
-  else if (SCM_COMPLEXP (prot))
-    return make_uve (scm_tc7_cvect, k, 2 * sizeof (double));
- dvect:
-  return make_uve (scm_tc7_dvect, k, sizeof (double));
 }
 #undef FUNC_NAME
 
@@ -186,12 +207,31 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
       v = SCM_ARRAY_V (v);
     }
 
+  /* XXX - clean up
+   */
   if (scm_is_uniform_vector (v))
     {
       if (nprot)
 	return SCM_BOOL_T;
       else
-	return scm_eq_p (prot, scm_i_uniform_vector_prototype (v));
+	{
+#if SCM_ENABLE_DEPRECATED
+	  prot = scm_i_convert_old_prototype (prot);
+#endif
+	  return scm_eq_p (prot, scm_i_uniform_vector_creator (v));
+	}
+    }
+  else if (scm_is_true (scm_vector_p (v)))
+    {
+      if (nprot)
+	return SCM_BOOL_T;
+      else
+	{
+#if SCM_ENABLE_DEPRECATED
+	  prot = scm_i_convert_old_prototype (prot);
+#endif
+	  return scm_eq_p (prot, scm_i_proc_make_vector);
+	}
     }
 
   if (nprot)
@@ -520,7 +560,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
 	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
+      else if (scm_is_false (scm_procedure_p (prot)))
 	scm_array_fill_x (answer, prot);
       return answer;
     }
@@ -545,7 +585,7 @@ SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1,
     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
+  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))
@@ -2178,26 +2218,51 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
 	    "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.")
+	    "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
 {
-  SCM shp = SCM_EOL;
+  SCM shape, row;
-  SCM row = lst;
   SCM ra;
   unsigned long k;
-  long n;
+
-  k = scm_to_ulong (ndim);
+  shape = SCM_EOL;
-  while (k--)
+  row = lst;
+  if (scm_is_integer (ndim))
     {
-      n = scm_ilength (row);
+      size_t k = scm_to_size_t (ndim);
-      SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
+      while (k-- > 0)
-      shp = scm_cons (scm_from_long (n), shp);
+	{
-      if (SCM_NIMP (row))
+	  shape = scm_cons (scm_length (row), shape);
-	row = SCM_CAR (row);
+	  if (k > 0)
+	    row = scm_car (row);
+	}
     }
-  ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
+  else
+    {
+      while (1)
+	{
+	  shape = scm_cons (scm_list_2 (scm_car (ndim),
+					scm_sum (scm_sum (scm_car (ndim),
+							  scm_length (row)),
+						 scm_from_int (-1))),
+			    shape);
+	  ndim = scm_cdr (ndim);
+	  if (scm_is_pair (ndim))
+	    row = scm_car (row);
+	  else
+	    break;
+	}
+    }
+
+  ra = scm_dimensions_to_uniform_array (scm_reverse_x (shape, SCM_EOL), prot,
 					SCM_UNDEFINED);
-  if (scm_is_null (shp))
+  if (scm_is_null (shape))
     {
       SCM_ASRTGO (1 == scm_ilength (lst), badlst);
       scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
@@ -2507,7 +2572,10 @@ scm_i_legacy_tag (SCM v)
  *   #<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.
+ * 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
@@ -2544,7 +2612,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
   long i;
 
   scm_putc ('#', port);
-  if (ndim != 1)
+  if (rank != 1 || dim_specs[0].lbnd != 0)
     scm_intprint (ndim, 10, port);
   if (scm_is_uniform_vector (SCM_ARRAY_V (array)))
     scm_puts (scm_i_uniform_vector_tag (SCM_ARRAY_V (array)), port);
@@ -2570,13 +2638,223 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
   return scm_i_print_array_dimension (array, 0, base, port, pstate);
 }
 
+/* Read an array.  This function can also read vectors and uniform
+   vectors.  Also, the conflict between '#f' and '#f32' and '#f64' is
+   handled here.
+
+   C is the first character read after the '#'.
+*/
+
+typedef struct {
+  const char *tag;
+  SCM *proto_var;
+} tag_proto;
+
+static SCM scm_i_proc_make_vector;
+
+static tag_proto tag_proto_table[] = {
+  { "", &scm_i_proc_make_vector },
+  { "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 },
+  { NULL, NULL }
+};
+
+static SCM
+scm_i_tag_to_prototype (const char *tag, SCM port)
+{
+  tag_proto *tp;
+
+  for (tp = tag_proto_table; tp->tag; tp++)
+    if (!strcmp (tp->tag, tag))
+      return *(tp->proto_var);
+  
+#if SCM_ENABLE_DEPRECATED
+  {
+    /* Recognize the old syntax, producing the old prototypes.
+     */
+    SCM proto = SCM_EOL;
+    const char *instead;
+    switch (tag[0])
+      {
+      case 'a':
+	proto = SCM_MAKE_CHAR ('a');
+	instead = "???";
+	break;
+      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 = "???";
+	break;
+      }
+    if (!scm_is_eq (proto, SCM_EOL) && 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;
+      }
+  }
+#endif
+
+  scm_i_input_error (NULL, port,
+		     "unrecognized uniform array tag: ~a",
+		     scm_list_1 (scm_from_locale_string (tag)));
+  return SCM_BOOL_F;
+}
+
+SCM
+scm_i_read_array (SCM port, int c)
+{
+  size_t rank;
+  int got_rank;
+  char tag[80];
+  int tag_len;
+
+  SCM lower_bounds, elements;
+
+  /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
+     the array code can not deal with zero-length dimensions yet, and
+     we want to allow zero-length vectors, of course.
+  */
+  if (c == '(')
+    {
+      scm_ungetc (c, port);
+      return scm_vector (scm_read (port));
+    }
+
+  /* Disambiguate between '#f' and uniform floating point vectors.
+   */
+  if (c == 'f')
+    {
+      c = scm_getc (port);
+      if (c != '3' && c != '6')
+	{
+	  if (c != EOF)
+	    scm_ungetc (c, port);
+	  return SCM_BOOL_F;
+	}
+      rank = 1;
+      got_rank = 1;
+      tag[0] = 'f';
+      tag_len = 1;
+      goto continue_reading_tag;
+    }
+
+  /* Read rank.  We disallow arrays of rank zero since they do not
+     seem to work reliably yet. */
+  rank = 0;
+  got_rank = 0;
+  while ('0' <= c && c <= '9')
+    {
+      rank = 10*rank + c-'0';
+      got_rank = 1;
+      c = scm_getc (port);
+    }
+  if (!got_rank)
+    rank = 1;
+  else if (rank == 0)
+    scm_i_input_error (NULL, port,
+		       "array rank must be positive", SCM_EOL);
+
+  /* Read tag. */
+  tag_len = 0;
+ continue_reading_tag:
+  while (c != EOF && c != '(' && c != '@' && tag_len < 80)
+    {
+      tag[tag_len++] = c;
+      c = scm_getc (port);
+    }
+  tag[tag_len] = '\0';
+  
+  /* Read lower bounds. */
+  lower_bounds = SCM_EOL;
+  while (c == '@')
+    {
+      /* Yeah, right, we should use some ready-made integer parsing
+	 routine for this...
+       */
+
+      long lbnd = 0;
+      long sign = 1;
+
+      c = scm_getc (port);
+      if (c == '-')
+	{
+	  sign = -1;
+	  c = scm_getc (port);
+	}
+      while ('0' <= c && c <= '9')
+	{
+	  lbnd = 10*lbnd + c-'0';
+	  c = scm_getc (port);
+	}
+      lower_bounds = scm_cons (scm_from_long (sign*lbnd), lower_bounds);
+    }
+
+  /* Read nested lists of elements.
+   */
+  if (c != '(')
+    scm_i_input_error (NULL, port,
+		       "missing '(' in vector or array literal",
+		       SCM_EOL);
+  scm_ungetc (c, port);
+  elements = scm_read (port);
+
+  if (scm_is_null (lower_bounds))
+    lower_bounds = scm_from_size_t (rank);
+  else if (scm_ilength (lower_bounds) != rank)
+    scm_i_input_error (NULL, port,
+		       "the number of lower bounds must match the array rank",
+		       SCM_EOL);
+
+  /* Construct array. */
+  return scm_list_to_uniform_array (lower_bounds,
+				    scm_i_tag_to_prototype (tag, port),
+				    elements);
+}
+
 int 
 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
 {
   SCM v = exp;
   unsigned long base = 0;
 
-  if (SCM_ARRAYP (exp)) // && scm_is_uniform_vector (SCM_ARRAY_V (exp)))
+  if (SCM_ARRAYP (exp) && !SCM_ARRAYP (SCM_ARRAY_V (exp)))
     return scm_i_print_array (exp, port, pstate);
 
   scm_putc ('#', port);
@@ -2675,7 +2953,9 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
   SCM_ASRTGO (SCM_NIMP (ra), badarg);
 loop:
   if (scm_is_uniform_vector (ra))
-    return scm_i_uniform_vector_prototype (ra);
+    return scm_i_uniform_vector_creator (ra);
+  else if (scm_is_true (scm_vector_p (ra)))
+    return scm_i_proc_make_vector;
 
   switch SCM_TYP7 (ra)
     {
@@ -2744,6 +3024,10 @@ scm_init_unif ()
 							scm_from_int (3)));
   scm_add_feature ("array");
 #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_u1vector = scm_variable_ref (scm_c_lookup ("make-u1vector"));
 }
 
 /*

libguile/unif.h

@@ -118,6 +118,9 @@ SCM_API SCM scm_array_to_list (SCM v);
 SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
 SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate);
 SCM_API SCM scm_array_prototype (SCM ra);
+
+SCM_API SCM scm_i_read_array (SCM port, int c);
+
 SCM_API void scm_init_unif (void);
 
 #endif  /* SCM_UNIF_H */