re PR fortran/82173 ([meta-bug] Parameterized derived type errors)

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

	PR fortran/82173
	* decl.c (gfc_get_pdt_instance): Use the component initializer
	expression for the default, rather than the parameter value.
	* resolve.c (resolve_pdt): New function.
	(resolve_symbol): Call it. Remove false error, prohibiting
	deferred type parameters for dummy arguments.

	PR fortran/60483
	* primary.c (gfc_match_varspec): If the type of an associate
	name is unknown and yet there is a match, try resolving the
	target expression and using its type.

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

	PR fortran/82173
	* gfortran.dg/pdt_1.f03 : Eliminate spurious error checks.
	* gfortran.dg/pdt_2.f03 : The same.
	* gfortran.dg/pdt_3.f03 : The same.
	* gfortran.dg/pdt_4.f03 : Add 'modtype' and two new errors in
	module 'bad_vars'. Add error concerning assumed parameters and
	save attribute.
	* gfortran.dg/pdt_11.f03 : New test.

	PR fortran/60483
	* gfortran.dg/associate_9.f90 : Remove XFAIL and change to run.
	* gfortran.dg/associate_25.f90 : New test.
	* gfortran.dg/pdt_12.f03 : New test.

From-SVN: r252894

4 files changed, 83 insertions, 13 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8bdd635..b6abf24 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2017-09-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82173
+	* decl.c (gfc_get_pdt_instance): Use the component initializer
+	expression for the default, rather than the parameter value.
+	* resolve.c (resolve_pdt): New function.
+	(resolve_symbol): Call it. Remove false error, prohibiting
+	deferred type parameters for dummy arguments.
+
+	PR fortran/60483
+	* primary.c (gfc_match_varspec): If the type of an associate
+	name is unknown and yet there is a match, try resolving the
+	target expression and using its type.
+
 2017-09-15  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/82184
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f6e0a7f..18220a1 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3275,8 +3275,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	    kind_expr = gfc_copy_expr (actual_param->expr);
 	  else
 	    {
-	      if (param->value)
-		kind_expr = gfc_copy_expr (param->value);
+	      if (c1->initializer)
+		kind_expr = gfc_copy_expr (c1->initializer);
 	      else if (!(actual_param && param->attr.pdt_len))
 		{
 		  gfc_error ("The derived parameter '%qs' at %C does not "
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 25658d7..21e5be2 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2055,10 +2055,21 @@ 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.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
-      gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
-      return MATCH_ERROR;
+      if (sym->assoc && sym->assoc->target)
+	{
+	  gfc_resolve_expr (sym->assoc->target);
+	  sym->ts = sym->assoc->target->ts;
+	}
+
+      if (sym->ts.type == BT_UNKNOWN)
+	{
+	  gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
+	  return MATCH_ERROR;
+	}
     }
   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
            && m == MATCH_YES)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 91d05b3..89dea5f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -14125,6 +14125,57 @@ resolve_fl_parameter (gfc_symbol *sym)
 }
 
 
+/* Called by resolve_symbol to chack PDTs.  */
+
+static void
+resolve_pdt (gfc_symbol* sym)
+{
+  gfc_symbol *derived = NULL;
+  gfc_actual_arglist *param;
+  gfc_component *c;
+  bool const_len_exprs = true;
+  bool assumed_len_exprs = false;
+
+  if (sym->ts.type == BT_DERIVED)
+    derived = sym->ts.u.derived;
+  else if (sym->ts.type == BT_CLASS)
+    derived = CLASS_DATA (sym)->ts.u.derived;
+  else
+    gcc_unreachable ();
+
+  gcc_assert (derived->attr.pdt_type);
+
+  for (param = sym->param_list; param; param = param->next)
+    {
+      c = gfc_find_component (derived, param->name, false, true, NULL);
+      gcc_assert (c);
+      if (c->attr.pdt_kind)
+	continue;
+
+      if (param->expr && !gfc_is_constant_expr (param->expr)
+	  && c->attr.pdt_len)
+	const_len_exprs = false;
+      else if (param->spec_type == SPEC_ASSUMED)
+	assumed_len_exprs = true;
+    }
+
+  if (!const_len_exprs
+      && (sym->ns->proc_name->attr.is_main_program
+	  || sym->ns->proc_name->attr.flavor == FL_MODULE
+	  || sym->attr.save != SAVE_NONE))
+    gfc_error ("The AUTOMATIC object %qs at %L must not have the "
+	       "SAVE attribute or be a variable declared in the "
+	       "main program, a module or a submodule(F08/C513)",
+	       sym->name, &sym->declared_at);
+
+  if (assumed_len_exprs && !(sym->attr.dummy
+      || sym->attr.select_type_temporary || sym->attr.associate_var))
+    gfc_error ("The object %qs at %L with ASSUMED type parameters "
+	       "must be a dummy or a SELECT TYPE selector(F08/4.2)",
+	       sym->name, &sym->declared_at);
+}
+
+
 /* Do anything necessary to resolve a symbol.  Right now, we just
    assume that an otherwise unknown symbol is a variable.  This sort
    of thing commonly happens for symbols in module.  */
@@ -14381,15 +14432,6 @@ resolve_symbol (gfc_symbol *sym)
       return;
     }
 
-  if (sym->attr.dummy && sym->ts.type == BT_DERIVED
-      && sym->ts.u.derived->attr.pdt_type
-      && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED)
-    {
-      gfc_error ("%qs at %L cannot have DEFERRED type parameters because "
-		 "it is a dummy argument", sym->name, &sym->declared_at);
-      return;
-    }
-
   if (sym->attr.value && sym->ts.type == BT_CHARACTER)
     {
       gfc_charlen *cl = sym->ts.u.cl;
@@ -14927,6 +14969,9 @@ resolve_symbol (gfc_symbol *sym)
       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
     if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
       return;
+
+  if (sym->param_list)
+    resolve_pdt (sym);
 }