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

11 files changed, 149 insertions, 8 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a00706b..401d66d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+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-02  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/52325
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 43c558a..bdb8c39 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2600,9 +2600,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
     }
 
 
-  m = gfc_match (" type ( %n", name);
+  m = gfc_match (" type (");
   matched_type = (m == MATCH_YES);
-  
+  if (matched_type)
+    {
+      gfc_gobble_whitespace ();
+      if (gfc_peek_ascii_char () == '*')
+	{
+	  if ((m = gfc_match ("*)")) != MATCH_YES)
+	    return m;
+	  if (gfc_current_state () == COMP_DERIVED)
+	    {
+	      gfc_error ("Assumed type at %C is not allowed for components");
+	      return MATCH_ERROR;
+	    }
+	  if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type "
+			  "at %C") == FAILURE)
+	    return MATCH_ERROR;
+	  ts->type = BT_ASSUMED;
+	  return MATCH_YES;
+	}
+
+      m = gfc_match ("%n", name);
+      matched_type = (m == MATCH_YES);
+    }
+
   if ((matched_type && strcmp ("integer", name) == 0)
       || (!matched_type && gfc_match (" integer") == MATCH_YES))
     {
@@ -3854,9 +3876,9 @@ gfc_verify_c_interop (gfc_typespec *ts)
 	   ? SUCCESS : FAILURE;
   else if (ts->type == BT_CLASS)
     return FAILURE;
-  else if (ts->is_c_interop != 1)
+  else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
     return FAILURE;
-  
+
   return SUCCESS;
 }
 
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index c715b30..7f1d28f 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -94,6 +94,12 @@ show_indent (void)
 static void
 show_typespec (gfc_typespec *ts)
 {
+  if (ts->type == BT_ASSUMED)
+    {
+      fputs ("(TYPE(*))", dumpfile);
+      return;
+    }
+
   fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
 
   switch (ts->type)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index d136140..e6a9c88 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -336,6 +336,7 @@ gfc_copy_expr (gfc_expr *p)
 	case BT_LOGICAL:
 	case BT_DERIVED:
 	case BT_CLASS:
+	case BT_ASSUMED:
 	  break;		/* Already done.  */
 
 	case BT_PROCEDURE:
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e9df662..298ae23d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -514,7 +514,8 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
   if (r1 != r2)
     return 0;			/* Ranks differ.  */
 
-  return gfc_compare_types (&s1->ts, &s2->ts);
+  return gfc_compare_types (&s1->ts, &s2->ts)
+	 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; 
 }
 
 
@@ -1697,6 +1698,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && actual->ts.type != BT_HOLLERITH
+      && formal->ts.type != BT_ASSUMED
       && !gfc_compare_types (&formal->ts, &actual->ts)
       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
 	   && gfc_compare_derived_types (formal->ts.u.derived, 
@@ -2274,6 +2276,27 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 			      is_elemental, where))
 	return 0;
 
+      /* TS 29113, 6.3p2.  */
+      if (f->sym->ts.type == BT_ASSUMED
+	  && (a->expr->ts.type == BT_DERIVED
+	      || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
+	{
+	  gfc_namespace *f2k_derived;
+
+	  f2k_derived = a->expr->ts.type == BT_DERIVED
+			? a->expr->ts.u.derived->f2k_derived
+			: CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
+
+	  if (f2k_derived
+	      && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
+	    {
+	      gfc_error ("Actual argument at %L to assumed-type dummy is of "
+			 "derived type with type-bound or FINAL procedures",
+			 &a->expr->where);
+	      return FAILURE;
+	    }
+	}
+
       /* Special case for character arguments.  For allocatable, pointer
 	 and assumed-shape dummies, the string length needs to match
 	 exactly.  */
@@ -2885,7 +2908,6 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 void
 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
-
   /* Warn about calls with an implicit interface.  Special case
      for calling a ISO_C_BINDING becase c_loc and c_funloc
      are pseudo-unknown.  Additionally, warn about procedures not
@@ -2938,6 +2960,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	      break;
 	    }
 
+	  /* TS 29113, 6.2.  */
+	  if (a->expr && a->expr->ts.type == BT_ASSUMED
+	      && sym->intmod_sym_id != ISOCBINDING_LOC)
+	    {
+	      gfc_error ("Assumed-type argument %s at %L requires an explicit "
+			 "interface", a->expr->symtree->n.sym->name,
+			 &a->expr->where);
+	      break;
+	    }
+
 	  /* F2008, C1303 and C1304.  */
 	  if (a->expr
 	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 3f36fe8..62afc21 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -129,6 +129,7 @@ libgfortran_stat_codes;
    used in the run-time library for IO.  */
 typedef enum
 { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
-  BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID
+  BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
+  BT_ASSUMED
 }
 bt;
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 05aef9f..012364a 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -107,6 +107,9 @@ gfc_basic_typename (bt type)
     case BT_UNKNOWN:
       p = "UNKNOWN";
       break;
+    case BT_ASSUMED:
+      p = "TYPE(*)";
+      break;
     default:
       gfc_internal_error ("gfc_basic_typename(): Undefined type");
     }
@@ -157,6 +160,9 @@ gfc_typename (gfc_typespec *ts)
       sprintf (buffer, "CLASS(%s)",
 	       ts->u.derived->components->ts.u.derived->name);
       break;
+    case BT_ASSUMED:
+      sprintf (buffer, "TYPE(*)");
+      break;
     case BT_PROCEDURE:
       strcpy (buffer, "PROCEDURE");
       break;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 5e0f26e..36ef4f8 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2244,6 +2244,7 @@ static const mstring bt_types[] = {
     minit ("PROCEDURE", BT_PROCEDURE),
     minit ("UNKNOWN", BT_UNKNOWN),
     minit ("VOID", BT_VOID),
+    minit ("ASSUMED", BT_ASSUMED),
     minit (NULL, -1)
 };
 
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
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3552da3..d69399c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3619,7 +3619,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			&& CLASS_DATA (e)->attr.dimension)
 		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
 
-		  if (fsym && fsym->ts.type == BT_DERIVED
+		  if (fsym && (fsym->ts.type == BT_DERIVED
+			       || fsym->ts.type == BT_ASSUMED)
 		      && e->ts.type == BT_CLASS
 		      && !CLASS_DATA (e)->attr.dimension
 		      && !CLASS_DATA (e)->attr.codimension)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 2579e23..6ff1d33 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1118,6 +1118,7 @@ gfc_typenode_for_spec (gfc_typespec * spec)
         }
       break;
     case BT_VOID:
+    case BT_ASSUMED:
       /* This is for the second arg to c_f_pointer and c_f_procpointer
          of the iso_c_binding module, to accept any ptr type.  */
       basetype = ptr_type_node;
@@ -1416,6 +1417,10 @@ gfc_get_dtype (tree type)
       n = BT_CHARACTER;
       break;
 
+    case POINTER_TYPE:
+      n = BT_ASSUMED;
+      break;
+
     default:
       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
       /* We can strange array types for temporary arrays.  */