[Patch, Fortran] Add parsing support for assumed-rank array

[Tobias Burnus <burnus at net-b dot de>]

To cleanup my local trees; I had the patch lingering there for a many weeks.

User visible, it only adds parsing support for "dimension(..)" and a 
sorry message.

Internally, it implements a basic support for assumed-shape arrays. 
There are still many constraint checks missing, scalar actual arguments 
to assumed-rank dummies have issues, and many intrinsics do not yet 
handle assumed-rank arguments.

In order to be more useful, some C binding changes and the 
implementation of IS_CONTIGUOUS is required. However, the big stumbling 
block for practical usage is the array descriptor: Instead of using the 
TS29113 one, gfortran's internal one is passed. [Cf. array descriptor 
reform.*]

Build on x86-64-linux.
OK for the trunk?

Tobias

* Talking about the new array descriptor, we really should find out why 
the following patch fails: 
http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html
2012-06-12  Tobias Burnus  <burnus@net-b.de>

	* array.c (gfc_match_array_spec, gfc_match_array_spec): Add support
	for assumed-rank arrays.
	* check.c (dim_rank_check): Ditto.
	* dump-parse-tree.c (show_array_spec): Ditto.
	* gfortran.h (array_type): Ditto.
	* interface.c (compare_type_rank, compare_parameter): Ditto.
	* resolve.c (resolve_formal_arglist, resolve_global_procedure,
	expression_shape, resolve_variable, resolve_symbol): Ditto.
	* simplify.c (simplify_bound, gfc_simplify_range): Ditto.
	* trans-array.c (gfc_conv_array_parameter): Ditto.
	* trans-decl. (gfc_build_dummy_array_decl,
	gfc_trans_deferred_vars): Ditto.
	* trans-types.c (gfc_is_nodesc_array, gfc_build_array_type,
	gfc_get_array_descriptor_base): Ditto.

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index b36d517..5b412dc 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -457,6 +457,24 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
       goto coarray;
     }
 
+  if (gfc_match (" .. )") == MATCH_YES)
+    {
+      as->type = AS_ASSUMED_RANK;
+      as->rank = -1;
+
+      if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+			  "at %C") == FAILURE)
+	goto cleanup;
+
+      gfc_error ("Sorry, support for assumed-rank array at %C is not yet "
+		 "implemented");
+      goto cleanup;
+
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
+
   for (;;)
     {
       as->rank++;
@@ -535,6 +553,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
 
 	    gfc_error ("Bad specification for assumed size array at %C");
 	    goto cleanup;
+
+	  case AS_ASSUMED_RANK:
+	    gcc_unreachable (); 
 	  }
 
       if (gfc_match_char (')') == MATCH_YES)
@@ -641,6 +662,9 @@ coarray:
 	    case AS_ASSUMED_SIZE:
 	      gfc_error ("Bad specification for assumed size array at %C");
 	      goto cleanup;
+
+	    case AS_ASSUMED_RANK:
+	      gcc_unreachable (); 
 	  }
 
       if (gfc_match_char (']') == MATCH_YES)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9926f05..ff71ff5 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -618,6 +618,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
   else
     rank = array->rank;
 
+  /* Assumed-rank array.  */
+  if (rank == -1)
+    rank = GFC_MAX_DIMENSIONS;
+
   if (array->expr_type == EXPR_VARIABLE)
     {
       ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 7f1d28f..14909f4 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -173,6 +173,7 @@ show_array_spec (gfc_array_spec *as)
 	case AS_DEFERRED:      c = "AS_DEFERRED";      break;
 	case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
 	case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+	case AS_ASSUMED_RANK:  c = "AS_ASSUMED_RANK";  break;
 	default:
 	  gfc_internal_error ("show_array_spec(): Unhandled array shape "
 			      "type.");
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 759074a..454d873 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -132,7 +132,8 @@ expr_t;
 /* Array types.  */
 typedef enum
 { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
-  AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+  AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+  AS_UNKNOWN
 }
 array_type;
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 95439c1..13f3ee8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -511,7 +511,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
   r1 = (s1->as != NULL) ? s1->as->rank : 0;
   r2 = (s2->as != NULL) ? s2->as->rank : 0;
 
-  if (r1 != r2)
+  if (r1 != r2
+      && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+      && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
     return 0;			/* Ranks differ.  */
 
   return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1842,7 +1844,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		     " is modified",  &actual->where, formal->name);
     }
 
-  if (symbol_rank (formal) == actual->rank)
+  /* If the rank is the same or the formal argument has assumed-rank.  */
+  if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
     return 1;
 
   if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8531318..63dd79e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -239,7 +239,7 @@ resolve_formal_arglist (gfc_symbol *proc)
 
   if (gfc_elemental (proc)
       || sym->attr.pointer || sym->attr.allocatable
-      || (sym->as && sym->as->rank > 0))
+      || (sym->as && sym->as->rank != 0))
     {
       proc->attr.always_explicit = 1;
       sym->attr.always_explicit = 1;
@@ -299,6 +299,7 @@ resolve_formal_arglist (gfc_symbol *proc)
 	}
 
       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+	  || (sym->as && sym->as->type == AS_ASSUMED_RANK)
 	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 	  || sym->attr.optional)
 	{
@@ -2195,6 +2196,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 			   sym->name, &sym->declared_at, arg->sym->name);
 		break;
 	      }
+	    /* TS 29113, 6.2.  */
+	    else if (arg->sym && arg->sym->as
+		     && arg->sym->as->type == AS_ASSUMED_RANK)
+	      {
+		gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+			   "argument '%s' must have an explicit interface",
+			   sym->name, &sym->declared_at, arg->sym->name);
+		break;
+	      }
 	    /* F2008, 12.4.2.2 (2c)  */
 	    else if (arg->sym->attr.codimension)
 	      {
@@ -2220,6 +2230,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
 			   sym->name, &sym->declared_at, arg->sym->name);
 		break;
 	      }
+	    /* As assumed-type is unlimited polymorphic (cf. above).
+	       See also  TS 29113, Note 6.1.  */
+	    else if (arg->sym->ts.type == BT_ASSUMED)
+	      {
+		gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+			   "argument '%s' must have an explicit interface",
+			   sym->name, &sym->declared_at, arg->sym->name);
+		break;
+	      }
 	}
 
       if (def_sym->attr.function)
@@ -4965,7 +4984,7 @@ expression_shape (gfc_expr *e)
   mpz_t array[GFC_MAX_DIMENSIONS];
   int i;
 
-  if (e->rank == 0 || e->shape != NULL)
+  if (e->rank <= 0 || e->shape != NULL)
     return;
 
   for (i = 0; i < e->rank; i++)
@@ -5085,6 +5104,17 @@ resolve_variable (gfc_expr *e)
       return FAILURE;
     }
 
+  /* TS 29113, C535b.  */
+  if (sym->as && sym->as->type == AS_ASSUMED_RANK && e->ref
+      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+           && e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-rank variable %s with designator at %L",
+                 sym->name, &e->ref->u.ar.where);
+      return FAILURE;
+    }
+
+
   /* If this is an associate-name, it may be parsed with an array reference
      in error even though the target is scalar.  Fail directly in this case.
      TODO Understand why class scalar expressions must be excluded.  */
@@ -12464,6 +12494,20 @@ resolve_symbol (gfc_symbol *sym)
 		       &sym->declared_at);
 	  return;
 	}
+      /* TS 29113, C535a.  */
+      if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+	{
+	  gfc_error ("Assumed-rank array at %L must be a dummy argument",
+		     &sym->declared_at);
+	  return;
+	}
+      if (as->type == AS_ASSUMED_RANK
+	  && (sym->attr.codimension || sym->attr.value))
+	{
+	  gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+		     "CODIMENSION attribute", &sym->declared_at);
+	  return;
+	}
     }
 
   /* Make sure symbols with known intent or optional are really dummy
@@ -12536,6 +12580,13 @@ resolve_symbol (gfc_symbol *sym)
 		     sym->name, &sym->declared_at);
 	  return;
 	}
+      if (sym->attr.intent == INTENT_OUT)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "INTENT(OUT) attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
       if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
 	{
 	  gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 1578db1..13c8589 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2934,7 +2934,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 }
 
 
-
 gfc_expr *
 gfc_simplify_is_iostat_end (gfc_expr *x)
 {
@@ -3380,7 +3378,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
  done:
 
-  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+	     || as->type == AS_ASSUMED_RANK))
     return NULL;
 
   if (dim == NULL)
@@ -3442,13 +3441,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
       d = mpz_get_si (dim->value.integer);
 
-      if (d < 1 || d > array->rank
+      if ((d < 1 || d > array->rank)
 	  || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
 	{
 	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
 	  return &gfc_bad_expr;
 	}
 
+      if (as && as->type == AS_ASSUMED_RANK)
+	return NULL;
+
       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
     }
 }
@@ -4779,6 +4781,10 @@ gfc_simplify_range (gfc_expr *e)
 gfc_expr *
 gfc_simplify_rank (gfc_expr *e)
 {
+  /* Assumed rank.  */
+  if (e->rank == -1)
+    return NULL;
+
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
 }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0e78210..3011cbb 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6892,9 +6892,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 	}
 
       if (!sym->attr.pointer
-	    && sym->as
-	    && sym->as->type != AS_ASSUMED_SHAPE 
-            && !sym->attr.allocatable)
+	  && sym->as
+	  && sym->as->type != AS_ASSUMED_SHAPE 
+	  && sym->as->type != AS_ASSUMED_RANK 
+	  && !sym->attr.allocatable)
         {
 	  /* Some variables are declared directly, others are declared as
 	     pointers and allocated on the heap.  */
@@ -6930,10 +6931,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
   no_pack = ((sym && sym->as
 		  && !sym->attr.pointer
 		  && sym->as->type != AS_DEFERRED
+		  && sym->as->type != AS_ASSUMED_RANK
 		  && sym->as->type != AS_ASSUMED_SHAPE)
 		      ||
 	     (ref && ref->u.ar.as
 		  && ref->u.ar.as->type != AS_DEFERRED
+		  && ref->u.ar.as->type != AS_ASSUMED_RANK
 		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
 		      ||
 	     gfc_is_simply_contiguous (expr, false));
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..b7e137e 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   int n;
   bool known_size;
 
-  if (sym->attr.pointer || sym->attr.allocatable)
+  if (sym->attr.pointer || sym->attr.allocatable
+      || (sym->as && sym->as->type == AS_ASSUMED_RANK))
     return dummy;
 
   /* Add to list of variables if not a fake result variable.  */
@@ -3670,6 +3671,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      break;
 
 	    case AS_DEFERRED:
+	    case AS_ASSUMED_RANK:
 	      seen_trans_deferred_array = true;
 	      gfc_trans_deferred_array (sym, block);
 	      break;
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..c6088e0 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1277,7 +1277,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
     return 0;
 
   if (sym->attr.dummy)
-    return sym->as->type != AS_ASSUMED_SHAPE;
+    return sym->as->type != AS_ASSUMED_SHAPE
+	   && sym->as->type != AS_ASSUMED_RANK;
 
   if (sym->attr.result || sym->attr.function)
     return 0;
@@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
   tree ubound[GFC_MAX_DIMENSIONS];
   int n;
 
+  if (as->type == AS_ASSUMED_RANK)
+    for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+      {
+	lbound[n] = NULL_TREE;
+	ubound[n] = NULL_TREE;
+      }
+
   for (n = 0; n < as->rank; n++)
     {
       /* Create expressions for the known bounds of the array.  */
@@ -1323,7 +1331,9 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
   if (as->type == AS_ASSUMED_SHAPE)
     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
 		       : GFC_ARRAY_ASSUMED_SHAPE;
-  return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+  return gfc_get_array_type_bounds (type, as->rank == -1
+					  ? GFC_MAX_DIMENSIONS : as->rank,
+				    as->corank, lbound,
 				    ubound, 0, akind, restricted);
 }
 
@@ -1684,6 +1694,10 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
   int idx = 2 * (codimen + dimen - 1) + restricted;
 
+  /* Assumed-rank array.  */
+  if (dimen == -1)
+    dimen = GFC_MAX_DIMENSIONS;
+
   gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)