re PR fortran/82375 (PDT components in PDT declarations fail to compile)

2017-10-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82375
	* class.c (gfc_find_derived_vtab): Return NULL for a passed
	pdt template to prevent bad procedures from being written.
	* decl.c (gfc_get_pdt_instance): Do not use the default
	initializer for pointer and allocatable pdt type components. If
	the component is allocatbale, set the 'alloc_comp' attribute of
	'instance'.
	* module.c : Add a prototype for 'mio_actual_arglist'. Add a
	boolean argument 'pdt'.
	(mio_component): Call it for the parameter list of pdt type
	components with 'pdt' set to true.
	(mio_actual_arg): Add the boolean 'pdt' and, if it is set, call
	mio_integer for the 'spec_type'.
	(mio_actual_arglist): Add the boolean 'pdt' and use it in the
	call to mio_actual_arg.
	(mio_expr, mio_omp_udr_expr): Call mio_actual_arglist with
	'pdt' set false.
	* resolve.c (get_pdt_spec_expr): Add the parameter name to the
	KIND parameter error.
	(get_pdt_constructor): Check that cons->expr is non-null.
	* trans-array.c (structure_alloc_comps): For deallocation of
	allocatable components, ensure that parameterized components
	are deallocated first. Likewise, when parameterized components
	are allocated, nullify allocatable components first. Do not
	recurse into pointer or allocatable pdt components while
	allocating or deallocating parameterized components. Test that
	parameterized arrays or strings are allocated before freeing
	them.
	(gfc_trans_pointer_assignment): Call the new function. Tidy up
	a minor whitespace issue.
	trans-decl.c (gfc_trans_deferred_vars): Set 'tmp' to NULL_TREE
	to prevent the expression from being used a second time.

2017-10-07  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82375
	* gfortran.dg/pdt_13.f03 : New test.
	* gfortran.dg/pdt_14.f03 : New test.
	* gfortran.dg/pdt_15.f03 : New test.

From-SVN: r253514

7 files changed, 91 insertions, 13 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 67a5b02..c9e81aa2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,38 @@
+2017-10-07  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82375
+	* class.c (gfc_find_derived_vtab): Return NULL for a passed
+	pdt template to prevent bad procedures from being written.
+	* decl.c (gfc_get_pdt_instance): Do not use the default
+	initializer for pointer and allocatable pdt type components. If
+	the component is allocatbale, set the 'alloc_comp' attribute of
+	'instance'.
+	* module.c : Add a prototype for 'mio_actual_arglist'. Add a
+	boolean argument 'pdt'.
+	(mio_component): Call it for the parameter list of pdt type
+	components with 'pdt' set to true.
+	(mio_actual_arg): Add the boolean 'pdt' and, if it is set, call
+	mio_integer for the 'spec_type'.
+	(mio_actual_arglist): Add the boolean 'pdt' and use it in the
+	call to mio_actual_arg.
+	(mio_expr, mio_omp_udr_expr): Call mio_actual_arglist with
+	'pdt' set false.
+	* resolve.c (get_pdt_spec_expr): Add the parameter name to the
+	KIND parameter error.
+	(get_pdt_constructor): Check that cons->expr is non-null.
+	* trans-array.c (structure_alloc_comps): For deallocation of
+	allocatable components, ensure that parameterized components
+	are deallocated first. Likewise, when parameterized components
+	are allocated, nullify allocatable components first. Do not
+	recurse into pointer or allocatable pdt components while
+	allocating or deallocating parameterized components. Test that
+	parameterized arrays or strings are allocated before freeing
+	them.
+	(gfc_trans_pointer_assignment): Call the new function. Tidy up
+	a minor whitespace issue.
+	trans-decl.c (gfc_trans_deferred_vars): Set 'tmp' to NULL_TREE
+	to prevent the expression from being used a second time.
+
 2017-10-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/49232
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index a345d13..ebbd41b 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2211,6 +2211,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_gsymbol *gsym = NULL;
   gfc_symbol *dealloc = NULL, *arg = NULL;
 
+  if (derived->attr.pdt_template)
+    return NULL;
+
   /* Find the top-level namespace.  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     if (!ns->parent)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 18220a1..5bf56c4 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3570,7 +3570,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	  type_param_spec_list = old_param_spec_list;
 
 	  c2->param_list = params;
-	  c2->initializer = gfc_default_initializer (&c2->ts);
+	  if (!(c2->attr.pointer || c2->attr.allocatable))
+	    c2->initializer = gfc_default_initializer (&c2->ts);
+
+	  if (c2->attr.allocatable)
+	    instance->attr.alloc_comp = 1;
 	}
     }
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 63877a0..3f19a02 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2788,6 +2788,7 @@ mio_component_ref (gfc_component **cp)
 static void mio_namespace_ref (gfc_namespace **nsp);
 static void mio_formal_arglist (gfc_formal_arglist **formal);
 static void mio_typebound_proc (gfc_typebound_proc** proc);
+static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
 
 static void
 mio_component (gfc_component *c, int vtype)
@@ -2819,6 +2820,9 @@ mio_component (gfc_component *c, int vtype)
   /* PDT templates store the expression for the kind of a component here.  */
   mio_expr (&c->kind_expr);
 
+  /* PDT types store component specification list here. */
+  mio_actual_arglist (&c->param_list, true);
+
   mio_symbol_attribute (&c->attr);
   if (c->ts.type == BT_CLASS)
     c->attr.class_ok = 1;
@@ -2874,17 +2878,19 @@ mio_component_list (gfc_component **cp, int vtype)
 
 
 static void
-mio_actual_arg (gfc_actual_arglist *a)
+mio_actual_arg (gfc_actual_arglist *a, bool pdt)
 {
   mio_lparen ();
   mio_pool_string (&a->name);
   mio_expr (&a->expr);
+  if (pdt)
+    mio_integer ((int *)&a->spec_type);
   mio_rparen ();
 }
 
 
 static void
-mio_actual_arglist (gfc_actual_arglist **ap)
+mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
 {
   gfc_actual_arglist *a, *tail;
 
@@ -2893,7 +2899,7 @@ mio_actual_arglist (gfc_actual_arglist **ap)
   if (iomode == IO_OUTPUT)
     {
       for (a = *ap; a; a = a->next)
-	mio_actual_arg (a);
+	mio_actual_arg (a, pdt);
 
     }
   else
@@ -2913,7 +2919,7 @@ mio_actual_arglist (gfc_actual_arglist **ap)
 	    tail->next = a;
 
 	  tail = a;
-	  mio_actual_arg (a);
+	  mio_actual_arg (a, pdt);
 	}
     }
 
@@ -3538,7 +3544,7 @@ mio_expr (gfc_expr **ep)
 
     case EXPR_FUNCTION:
       mio_symtree_ref (&e->symtree);
-      mio_actual_arglist (&e->value.function.actual);
+      mio_actual_arglist (&e->value.function.actual, false);
 
       if (iomode == IO_OUTPUT)
 	{
@@ -4203,7 +4209,7 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
 	  int flag;
 	  mio_name (1, omp_declare_reduction_stmt);
 	  mio_symtree_ref (&ns->code->symtree);
-	  mio_actual_arglist (&ns->code->ext.actual);
+	  mio_actual_arglist (&ns->code->ext.actual, false);
 
 	  flag = ns->code->resolved_isym != NULL;
 	  mio_integer (&flag);
@@ -4245,7 +4251,7 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
 	  int flag;
 	  ns->code = gfc_get_code (EXEC_CALL);
 	  mio_symtree_ref (&ns->code->symtree);
-	  mio_actual_arglist (&ns->code->ext.actual);
+	  mio_actual_arglist (&ns->code->ext.actual, false);
 
 	  mio_integer (&flag);
 	  if (flag)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fab7c23..bd31634 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1161,8 +1161,8 @@ get_pdt_spec_expr (gfc_component *c, gfc_expr *expr)
       param_tail->spec_type = SPEC_ASSUMED;
       if (c->attr.pdt_kind)
 	{
-	  gfc_error ("The KIND parameter in the PDT constructor "
-		     "at %C has no value");
+	  gfc_error ("The KIND parameter %qs in the PDT constructor "
+		     "at %C has no value", param->name);
 	  return false;
 	}
     }
@@ -1188,7 +1188,8 @@ get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr,
 
   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
     {
-      if (cons->expr->expr_type == EXPR_STRUCTURE
+      if (cons->expr
+	  && cons->expr->expr_type == EXPR_STRUCTURE
 	  && comp->ts.type == BT_DERIVED)
 	{
 	  t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 328da4e..a357389 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8400,6 +8400,19 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
       return tmp;
     }
 
+  if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
+    {
+      tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				   DEALLOCATE_PDT_COMP, 0);
+      gfc_add_expr_to_block (&fnblock, tmp);
+    }
+  else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
+    {
+      tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
+				   NULLIFY_ALLOC_COMP, 0);
+      gfc_add_expr_to_block (&fnblock, tmp);
+    }
+
   /* Otherwise, act on the components or recursively call self to
      act on a chain of components.  */
   for (c = der_type->components; c; c = c->next)
@@ -9072,7 +9085,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	  /* Recurse in to PDT components.  */
 	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
-	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+	      && !(c->attr.pointer || c->attr.allocatable))
 	    {
 	      bool is_deferred = false;
 	      gfc_actual_arglist *tail = c->param_list;
@@ -9106,7 +9120,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	  /* Recurse in to PDT components.  */
 	  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
-	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
+	      && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+	      && (!c->attr.pointer && !c->attr.allocatable))
 	    {
 	      tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
 					     c->as ? c->as->rank : 0);
@@ -9116,13 +9131,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  if (c->attr.pdt_array)
 	    {
 	      tmp = gfc_conv_descriptor_data_get (comp);
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, tmp,
+					   build_int_cst (TREE_TYPE (tmp), 0));
 	      tmp = gfc_call_free (tmp);
+	      tmp = build3_v (COND_EXPR, null_cond, tmp,
+			      build_empty_stmt (input_location));
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
 	    }
 	  else if (c->attr.pdt_string)
 	    {
+	      null_cond = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, comp,
+					   build_int_cst (TREE_TYPE (comp), 0));
 	      tmp = gfc_call_free (comp);
+	      tmp = build3_v (COND_EXPR, null_cond, tmp,
+			      build_empty_stmt (input_location));
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	      tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
 	      gfc_add_modify (&fnblock, comp, tmp);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index b4f515f..019b803 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4634,6 +4634,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		}
 
 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+	      /* TODO find out why this is necessary to stop double calls to
+		 free.  Somebody is reusing the expression in 'tmp' because
+		 it is being used unititialized.  */
+	      tmp = NULL_TREE;
 	    }
 	}
       else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)