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

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

        PR fortran/48820
        * decl.c (gfc_match_decl_type_spec): Support type(*).
        (gfc_verify_c_interop): Allow type(*).
        * dump-parse-tree.c (show_typespec): Handle type(*).
        * expr.c (gfc_copy_expr): Ditto.
        * interface.c (compare_type_rank, compare_parameter,
        compare_actual_formal, gfc_procedure_use): Ditto.
        * libgfortran.h (bt): Add BT_ASSUMED.
        * misc.c (gfc_basic_typename, gfc_typename): Handle type(*).
        * module.c (bt_types): Ditto.
        * resolve.c (assumed_type_expr_allowed): New static variable.
        (resolve_actual_arglist, resolve_variable, resolve_symbol):
        Handle type(*). 
        * trans-expr.c (gfc_conv_procedure_call): Ditto.
        * trans-types.c (gfc_typenode_for_spec, gfc_get_dtype): Ditto.

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

        PR fortran/48820
        * gfortran.dg/assumed_type_1.f90: New.
        * gfortran.dg/assumed_type_2.f90: New.
        * gfortran.dg/assumed_type_3.f90: New.
        * gfortran.dg/assumed_type_4.f90: New.

From-SVN: r184852

1 files changed, 48 insertions, 0 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 824bc25..618c6f5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -63,6 +63,8 @@ static code_stack *cs_base = NULL;
 static int forall_flag;
 static int do_concurrent_flag;
 
+static bool assumed_type_expr_allowed = false;
+
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
 static int omp_workshare_flag;
@@ -1597,6 +1599,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_expr *e;
   int save_need_full_assumed_size;
 
+  assumed_type_expr_allowed = true;
+
   for (; arg; arg = arg->next)
     {
       e = arg->expr;
@@ -1829,6 +1833,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
           return FAILURE;
         }
     }
+  assumed_type_expr_allowed = true;
 
   return SUCCESS;
 }
@@ -5057,6 +5062,24 @@ resolve_variable (gfc_expr *e)
     return FAILURE;
   sym = e->symtree->n.sym;
 
+  /* TS 29113, 407b.  */
+  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+    {
+      gfc_error ("Invalid expression with assumed-type variable %s at %L",
+		 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))
+    {
+      gfc_error ("Assumed-type 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.  */
   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
@@ -12435,6 +12458,31 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->ts.type == BT_ASSUMED)
+    { 
+      /* TS 29113, C407a.  */
+      if (!sym->attr.dummy)
+	{
+	  gfc_error ("Assumed type of variable %s at %L is only permitted "
+		     "for dummy variables", sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.allocatable || sym->attr.codimension
+	  || sym->attr.pointer || sym->attr.value)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "ALLOCATABLE, CODIMENSION, POINTER or VALUE 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 "
+		     "explicit-shape array", sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
   /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
      do this for something that was implicitly typed because that is handled
      in gfc_set_default_type.  Handle dummy arguments and procedure