re PR fortran/52832 ([F03] ASSOCIATE construct with proc-pointer selector is rejected)

2017-09-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/52832
	* match.c (gfc_match_associate): Before failing the association
	try again, allowing a proc pointer selector.

	PR fortran/80120
	PR fortran/81903
	PR fortran/82121
	* primary.c (gfc_match_varspec): Introduce 'tgt_expr', which
	points to the associate selector, if any. Go through selector
	references, after resolution for variables, to catch any full
	or section array references. If a class associate name does
	not have the same declared type as the selector, resolve the
	selector and copy the declared type to the associate name.
	Before throwing a no implicit type error, resolve all allowed
	selector expressions, and copy the resulting typespec.

	PR fortran/67543
	* resolve.c (resolve_assoc_var): Selector must cannot be the
	NULL expression and it must have a type.

	PR fortran/78152
	* resolve.c (resolve_symbol): Allow associate names to be
	coarrays.

2017-09-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78512
	* gfortran.dg/associate_26.f90 : New test.

	PR fortran/80120
	* gfortran.dg/associate_27.f90 : New test.

	PR fortran/81903
	* gfortran.dg/associate_28.f90 : New test.

	PR fortran/82121
	* gfortran.dg/associate_29.f90 : New test.

	PR fortran/67543
	* gfortran.dg/associate_30.f90 : New test.

	PR fortran/52832
	* gfortran.dg/associate_31.f90 : New test.

From-SVN: r253077

1 files changed, 50 insertions, 19 deletions

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 21e5be2..8537d93 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1937,6 +1937,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   gfc_ref *substring, *tail, *tmp;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
+  gfc_expr *tgt_expr = NULL;
   match m;
   bool unknown;
   char sep;
@@ -1965,6 +1966,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	}
     }
 
+  if (sym->assoc && sym->assoc->target)
+    tgt_expr = sym->assoc->target;
+
   /* For associate names, we may not yet know whether they are arrays or not.
      If the selector expression is unambiguously an array; eg. a full array
      or an array section, then the associate name must be an array and we can
@@ -1976,26 +1980,43 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       && sym->ts.type != BT_CLASS
       && !sym->attr.dimension)
     {
-      if ((!sym->assoc->dangling
-	   && sym->assoc->target
-	   && sym->assoc->target->ref
-	   && sym->assoc->target->ref->type == REF_ARRAY
-	   && (sym->assoc->target->ref->u.ar.type == AR_FULL
-	       || sym->assoc->target->ref->u.ar.type == AR_SECTION))
-	  ||
-	   (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
-	    && sym->assoc->st
-	   && sym->assoc->st->n.sym
-	    && sym->assoc->st->n.sym->attr.dimension == 0))
-	{
-    sym->attr.dimension = 1;
-	  if (sym->as == NULL && sym->assoc
+      gfc_ref *ref = NULL;
+
+      if (!sym->assoc->dangling && tgt_expr)
+	{
+	   if (tgt_expr->expr_type == EXPR_VARIABLE)
+	     gfc_resolve_expr (tgt_expr);
+
+	   ref = tgt_expr->ref;
+	   for (; ref; ref = ref->next)
+	      if (ref->type == REF_ARRAY
+		  && (ref->u.ar.type == AR_FULL
+		      || ref->u.ar.type == AR_SECTION))
+		break;
+	}
+
+      if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER)
+		  && sym->assoc->st
+		  && sym->assoc->st->n.sym
+		  && sym->assoc->st->n.sym->attr.dimension == 0))
+	{
+	  sym->attr.dimension = 1;
+	  if (sym->as == NULL
 	      && sym->assoc->st
 	      && sym->assoc->st->n.sym
 	      && sym->assoc->st->n.sym->as)
 	    sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
 	}
     }
+  else if (sym->ts.type == BT_CLASS
+	   && tgt_expr
+	   && tgt_expr->expr_type == EXPR_VARIABLE
+	   && sym->ts.u.derived != tgt_expr->ts.u.derived)
+    {
+      gfc_resolve_expr (tgt_expr);
+      if (tgt_expr->rank)
+	sym->ts.u.derived = tgt_expr->ts.u.derived;
+    }
 
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
@@ -2055,14 +2076,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
-  /* Before throwing an error try resolving the target expression of
-     associate names. This should resolve function calls, for example.  */
+  /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
-      if (sym->assoc && sym->assoc->target)
+      bool permissible;
+
+      /* These target expressions can ge resolved at any time.  */
+      permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
+		    && (tgt_expr->symtree->n.sym->attr.use_assoc
+			|| tgt_expr->symtree->n.sym->attr.host_assoc
+			|| tgt_expr->symtree->n.sym->attr.if_source
+								== IFSRC_DECL);
+      permissible = permissible
+		    || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
+
+      if (permissible)
 	{
-	  gfc_resolve_expr (sym->assoc->target);
-	  sym->ts = sym->assoc->target->ts;
+	  gfc_resolve_expr (tgt_expr);
+	  sym->ts = tgt_expr->ts;
 	}
 
       if (sym->ts.type == BT_UNKNOWN)