re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)

2012-07-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * array.c (match_array_element_spec, gfc_match_array_spec,
        spec_size, gfc_array_dimen_size): Add support for
        assumed-rank arrays.
        * check.c (dim_rank_check): Ditto.
        * class.c (gfc_add_component_ref): Ditto.
        (gfc_build_class_symbol): Regard assumed-rank arrays
        as having GFC_MAX_DIMENSIONS. And build extra class
        container for a scalar pointer class.
        * decl.c (merge_array_spec): Add assert.
        * dump-parse-tree.c (show_array_spec): Add support for
        assumed-rank arrays.
        * expr.c (gfc_is_simply_contiguous): Ditto.
        * gfortran.h (array_type): Ditto.
        (gfc_array_spec, gfc_expr): Add comment to "rank" field.
        * interface.c (compare_type_rank, argument_rank_mismatch,
        compare_parameter, gfc_procedure_use): Ditto.
        (compare_actual_formal): Fix NULL() to optional-dummy
        handling for polymorphic dummies.
        * module.c (mio_typespec): Add support for
        assumed-rank arrays.
        * resolve.c (resolve_formal_arglist, resolve_actual_arglist,
        resolve_elemental_actual, resolve_global_procedure,
        expression_shape, resolve_variable, update_ppc_arglist,
        check_typebound_baseobject, gfc_resolve_expr,
        resolve_fl_var_and_proc, gfc_resolve_finalizers,
        resolve_typebound_procedure, resolve_symbol): Ditto.
        (assumed_type_expr_allowed): Remove static variable.
        (actual_arg, first_actual_arg): New static variables.
        * simplify.c (simplify_bound, gfc_simplify_range): Add
        support for assumed-rank arrays.
        * trans-array.c (gfc_conv_array_parameter): Ditto.
        (gfc_get_descriptor_dimension): New function, which returns
        the descriptor.
        (gfc_conv_descriptor_dimension): Use it.
        (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter):
        Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK.
        * trans-array.h (gfc_get_descriptor_dimension): New prototype.
        * trans-decl. (gfc_build_dummy_array_decl,
        gfc_trans_deferred_vars, add_argument_checking): Add
        support for assumed-rank arrays.
        * trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
        gfc_conv_procedure_call): Ditto.
        (get_scalar_to_descriptor_type, class_array_data_assign,
        conv_scalar_to_descriptor): New static functions.
        (gfc_conv_derived_to_class, gfc_conv_class_to_class): Use
        them.
        * trans-intrinsic.c (get_rank_from_desc): New function.
        (gfc_conv_intrinsic_rank, gfc_conv_associated): Use it.
        * trans-types.c (gfc_array_descriptor_base_caf,
        gfc_array_descriptor_base): Make space for scalar array.
        (gfc_is_nodesc_array, gfc_is_nodesc_array,
        gfc_build_array_type, gfc_get_array_descriptor_base): Add
        support for assumed-rank arrays.
        * trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
        GFC_ARRAY_ASSUMED_RANK_CONT.

2012-07-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * gfortran.dg/assumed_type_3.f90: Update dg-error.
        * gfortran.dg/assumed_rank_1.f90: New.
        * gfortran.dg/assumed_rank_1_c.c: New.
        * gfortran.dg/assumed_rank_2.f90: New.
        * gfortran.dg/assumed_rank_4.f90: New.
        * gfortran.dg/assumed_rank_5.f90: New.
        * gfortran.dg/assumed_rank_6.f90: New.
        * gfortran.dg/assumed_rank_7.f90: New.
        * gfortran.dg/assumed_rank_8.f90: New.
        * gfortran.dg/assumed_rank_8_c.c: New.
        * gfortran.dg/assumed_rank_9.f90: New.
        * gfortran.dg/assumed_rank_10.f90: New.
        * gfortran.dg/assumed_rank_12.f90: New.

From-SVN: r189700

1 files changed, 169 insertions, 46 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 753f1c7..7e2d621 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -64,7 +64,13 @@ static code_stack *cs_base = NULL;
 static int forall_flag;
 static int do_concurrent_flag;
 
-static bool assumed_type_expr_allowed = false;
+/* True when we are resolving an expression that is an actual argument to
+   a procedure.  */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+   to a procedure.  */
+static bool first_actual_arg = false;
+
 
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
@@ -86,6 +92,7 @@ static bitmap_obstack labels_obstack;
 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
 static bool inquiry_argument = false;
 
+
 int
 gfc_is_formal_arg (void)
 {
@@ -240,7 +247,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;
@@ -307,6 +314,7 @@ resolve_formal_arglist (gfc_symbol *proc)
 	}
 
       if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
+	  || (as && as->type == AS_ASSUMED_RANK)
 	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
 	      && (CLASS_DATA (sym)->attr.class_pointer
@@ -1610,8 +1618,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_symtree *parent_st;
   gfc_expr *e;
   int save_need_full_assumed_size;
+  gfc_try return_value = FAILURE;
+  bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
 
-  assumed_type_expr_allowed = true;
+  actual_arg = true;
+  first_actual_arg = true;
 
   for (; arg; arg = arg->next)
     {
@@ -1625,9 +1636,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("Label %d referenced at %L is never defined",
 			     arg->label->value, &arg->label->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
+	  first_actual_arg = false;
 	  continue;
 	}
 
@@ -1635,7 +1647,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	    && e->symtree->n.sym->attr.generic
 	    && no_formal_args
 	    && count_specific_procs (e) != 1)
-	return FAILURE;
+	goto cleanup;
 
       if (e->ts.type != BT_PROCEDURE)
 	{
@@ -1643,7 +1655,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  if (e->expr_type != EXPR_VARIABLE)
 	    need_full_assumed_size = 0;
 	  if (gfc_resolve_expr (e) != SUCCESS)
-	    return FAILURE;
+	    goto cleanup;
 	  need_full_assumed_size = save_need_full_assumed_size;
 	  goto argument_list;
 	}
@@ -1687,7 +1699,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 				  "Internal procedure '%s' is"
 				  " used as actual argument at %L",
 				  sym->name, &e->where) == FAILURE)
-		return FAILURE;
+		goto cleanup;
 	    }
 
 	  if (sym->attr.elemental && !sym->attr.intrinsic)
@@ -1700,8 +1712,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  /* Check if a generic interface has a specific procedure
 	    with the same name before emitting an error.  */
 	  if (sym->attr.generic && count_specific_procs (e) != 1)
-	    return FAILURE;
-	  
+	    goto cleanup;
+
 	  /* Just in case a specific was found for the expression.  */
 	  sym = e->symtree->n.sym;
 
@@ -1722,7 +1734,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		  gfc_error ("Unable to find a specific INTRINSIC procedure "
 			     "for the reference '%s' at %L", sym->name,
 			     &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	      sym->ts = isym->ts;
 	      sym->attr.intrinsic = 1;
@@ -1730,7 +1742,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	    }
 
 	  if (gfc_resolve_expr (e) == FAILURE)
-	    return FAILURE;
+	    goto cleanup;
 	  goto argument_list;
 	}
 
@@ -1742,7 +1754,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
 	{
 	  gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
-	  return FAILURE;
+	  goto cleanup;
 	}
 
       if (parent_st == NULL)
@@ -1756,7 +1768,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  || sym->attr.external)
 	{
 	  if (gfc_resolve_expr (e) == FAILURE)
-	    return FAILURE;
+	    goto cleanup;
 	  goto argument_list;
 	}
 
@@ -1784,7 +1796,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
       if (e->expr_type != EXPR_VARIABLE)
 	need_full_assumed_size = 0;
       if (gfc_resolve_expr (e) != SUCCESS)
-	return FAILURE;
+	goto cleanup;
       need_full_assumed_size = save_need_full_assumed_size;
 
     argument_list:
@@ -1798,14 +1810,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("By-value argument at %L is not of numeric "
 			     "type", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 
 	      if (e->rank)
 		{
 		  gfc_error ("By-value argument at %L cannot be an array or "
 			     "an array section", &e->where);
-		return FAILURE;
+		  goto cleanup;
 		}
 
 	      /* Intrinsics are still PROC_UNKNOWN here.  However,
@@ -1819,7 +1831,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("By-value argument at %L is not allowed "
 			     "in this context", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
 
@@ -1831,23 +1843,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("Passing internal procedure at %L by location "
 			     "not allowed", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
 	}
 
       /* Fortran 2008, C1237.  */
       if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
-          && gfc_has_ultimate_pointer (e))
-        {
-          gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+	  && gfc_has_ultimate_pointer (e))
+	{
+	  gfc_error ("Coindexed actual argument at %L with ultimate pointer "
 		     "component", &e->where);
-          return FAILURE;
-        }
+	  goto cleanup;
+	}
+
+      first_actual_arg = false;
     }
-  assumed_type_expr_allowed = false;
 
-  return SUCCESS;
+  return_value = SUCCESS;
+
+cleanup:
+  actual_arg = actual_arg_sav;
+  first_actual_arg = first_actual_arg_sav;
+
+  return return_value;
 }
 
 
@@ -1907,7 +1926,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
   /* The rank of an elemental is the rank of its array argument(s).  */
   for (arg = arg0; arg; arg = arg->next)
     {
-      if (arg->expr != NULL && arg->expr->rank > 0)
+      if (arg->expr != NULL && arg->expr->rank != 0)
 	{
 	  rank = arg->expr->rank;
 	  if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2206,6 +2225,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)
 	      {
@@ -2231,6 +2259,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)
@@ -4976,7 +5013,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++)
@@ -5079,23 +5116,79 @@ resolve_variable (gfc_expr *e)
   sym = e->symtree->n.sym;
 
   /* TS 29113, 407b.  */
-  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+  if (e->ts.type == BT_ASSUMED)
     {
-      gfc_error ("Invalid expression with assumed-type variable %s at %L",
-		 sym->name, &e->where);
-      return FAILURE;
+      if (!actual_arg)
+	{
+	  gfc_error ("Assumed-type variable %s at %L may only be used "
+		     "as actual argument", sym->name, &e->where);
+	  return FAILURE;
+	}
+      else if (inquiry_argument && !first_actual_arg)
+	{
+	  /* FIXME: It doesn't work reliably as inquiry_argument is not set
+	     for all inquiry functions in resolve_function; the reason is
+	     that the function-name resolution happens too late in that
+	     function.  */
+	  gfc_error ("Assumed-type variable %s at %L as actual argument to "
+		     "an inquiry function shall be the first argument",
+		     sym->name, &e->where);
+	  return FAILURE;
+	}
+    }
+
+  /* TS 29113, C535b.  */
+  if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
+	&& CLASS_DATA (sym)->as
+	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+       || (sym->ts.type != BT_CLASS && sym->as
+	   && sym->as->type == AS_ASSUMED_RANK))
+    {
+      if (!actual_arg)
+	{
+	  gfc_error ("Assumed-rank variable %s at %L may only be used as "
+		     "actual argument", sym->name, &e->where);
+	  return FAILURE;
+	}
+      else if (inquiry_argument && !first_actual_arg)
+	{
+	  /* FIXME: It doesn't work reliably as inquiry_argument is not set
+	     for all inquiry functions in resolve_function; the reason is
+	     that the function-name resolution happens too late in that
+	     function.  */
+	  gfc_error ("Assumed-rank variable %s at %L as actual argument "
+		     "to an inquiry function shall be the first argument",
+		     sym->name, &e->where);
+	  return FAILURE;
+	}
     }
 
   /* TS 29113, 407b.  */
   if (e->ts.type == BT_ASSUMED && e->ref
       && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
-           && e->ref->next == NULL))
+	   && e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+		 "reference", sym->name, &e->ref->u.ar.where);
+      return FAILURE;
+    }
+
+  /* TS 29113, C535b.  */
+  if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+	&& CLASS_DATA (sym)->as
+	&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+       || (sym->ts.type != BT_CLASS && 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-type variable %s with designator at %L",
-                 sym->name, &e->ref->u.ar.where);
+      gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
+		 "reference", 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.  */
@@ -5596,7 +5689,7 @@ update_ppc_arglist (gfc_expr* e)
     return FAILURE;
 
   /* F08:R739.  */
-  if (po->rank > 0)
+  if (po->rank != 0)
     {
       gfc_error ("Passed-object at %L must be scalar", &e->where);
       return FAILURE;
@@ -5644,7 +5737,7 @@ check_typebound_baseobject (gfc_expr* e)
 
   /* F08:C1230. If the procedure called is NOPASS,
      the base object must be scalar.  */
-  if (e->value.compcall.tbp->nopass && base->rank > 0)
+  if (e->value.compcall.tbp->nopass && base->rank != 0)
     {
       gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
 		 " be scalar", &e->where);
@@ -6306,15 +6399,22 @@ gfc_try
 gfc_resolve_expr (gfc_expr *e)
 {
   gfc_try t;
-  bool inquiry_save;
+  bool inquiry_save, actual_arg_save, first_actual_arg_save;
 
   if (e == NULL)
     return SUCCESS;
 
   /* inquiry_argument only applies to variables.  */
   inquiry_save = inquiry_argument;
+  actual_arg_save = actual_arg;
+  first_actual_arg_save = first_actual_arg;
+
   if (e->expr_type != EXPR_VARIABLE)
-    inquiry_argument = false;
+    {
+      inquiry_argument = false;
+      actual_arg = false;
+      first_actual_arg = false;
+    }
 
   switch (e->expr_type)
     {
@@ -6404,6 +6504,8 @@ gfc_resolve_expr (gfc_expr *e)
     fixup_charlen (e);
 
   inquiry_argument = inquiry_save;
+  actual_arg = actual_arg_save;
+  first_actual_arg = first_actual_arg_save;
 
   return t;
 }
@@ -10332,10 +10434,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 
       if (allocatable)
 	{
-	  if (dimension)
+	  if (dimension && as->type != AS_ASSUMED_RANK)
 	    {
-	      gfc_error ("Allocatable array '%s' at %L must have "
-			 "a deferred shape", sym->name, &sym->declared_at);
+	      gfc_error ("Allocatable array '%s' at %L must have a deferred "
+			 "shape or assumed rank", sym->name, &sym->declared_at);
 	      return FAILURE;
 	    }
 	  else if (gfc_notify_std (GFC_STD_F2003, "Scalar object "
@@ -10344,10 +10446,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	    return FAILURE;
 	}
 
-      if (pointer && dimension)
+      if (pointer && dimension && as->type != AS_ASSUMED_RANK)
 	{
-	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
-		     sym->name, &sym->declared_at);
+	  gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+		     "assumed rank", sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
     }
@@ -10961,7 +11063,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
 	}
 
       /* Warn if the procedure is non-scalar and not assumed shape.  */
-      if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+      if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
 	  && arg->as->type != AS_ASSUMED_SHAPE)
 	gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
 		     " shape argument", &arg->declared_at);
@@ -11490,7 +11592,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	}
   
       gcc_assert (me_arg->ts.type == BT_CLASS);
-      if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+      if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
 	{
 	  gfc_error ("Passed-object dummy argument of '%s' at %L must be"
 		     " scalar", proc->name, &where);
@@ -12504,6 +12606,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
@@ -12576,6 +12692,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 "