Re: [Patch, Fortran, PR58586, v2] ICE with derived type with allocatable component passed by value

[Andre Vehreschild <vehre at gmx dot de>]

Hi Mikael, hi all,

thanks for the review. I have made some changes. Answers to your questions are
inline below.

On Sun, 19 Apr 2015 12:01:23 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:

<snip>
> > I was pointed to the patch in comment #44 of pr61831 which seemingly fixes
> > the #3 comment of pr58586, too, but causes a memory leak. I therefore like
> > to point out, that adding the a->expr.expr_type != EXPR_STRUCTURE of
> > Mikael's patch in pr61831 should not be added to
> > trans-expr.c::gfc_conv_procedure_call (), when this patch for 58586 is
> > applied.
> Note that I plan to submit the pr61831 patch soon, and that the comment
> #44 patch doesn't have the a->expr.expr_type != EXPR_STRUCTURE (in
> opposition to precedent patches).
> I hope that means the patches are compatible. ;-)

I have tested the code in the comments of pr61831 with v2 of this patch and got
no issues.

> > diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> > index 9e6432f..80dfed1 100644
> > --- a/gcc/fortran/trans-expr.c
> > +++ b/gcc/fortran/trans-expr.c
> > @@ -5344,8 +5344,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
> > sym, && (e->expr_type != EXPR_VARIABLE && !e->rank))
> >          {
> >  	  int parm_rank;
> > -	  tmp = build_fold_indirect_ref_loc (input_location,
> > -					 parmse.expr);
> > +	  /* It is known the e returns a structure type with at least one
> > +	     allocatable component.  When e is a function, ensure that the
> > +	     function is called once only by using a temporary variable.
> > */
> > +	  if (e->expr_type == EXPR_FUNCTION)
> > +	    parmse.expr = gfc_evaluate_now_loc (input_location,
> > +						parmse.expr, &se->pre);
> You need not limit this to functions only.
> I think you can even do this without condition.

Yes, one could do that, but then an unnecessary temporary variable in the - for
my taste - already too clobbered pseudo code is introduced. Furthermore, is the
penalty on doing the check for a function negligible. I therefore have not
changed that.

> > +	  if (POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
> This distinguishes arguments with/without value attribute, right?
> I think it's better to use the frontend information here (fsym->attr.value).

Changed to check for value.

> Ah, and don't forget to provide a ChangeLog entry with it.

The Changelog entry comes in an additional attachment. 

Version 2 of this patch adds a chunk to resolve.c, where results of
functions that are defined in a module, but are not referenced there, are
now marked referenced when they use allocatable or pointer components.
Furthermore, does the chunk prevent duplicate pseudo code generation. The
former code adds a EXPR_INIT_ASSIGN and then gfc_generate_function_code ()
does nearly the same again. I fixed this in both place. I also have added a
test to check this. 

The chunks in trans-decl.c take care to have variable/result declaration and
initialize it properly. For this I had to make gfc_trans_structure_assign ()
public to the trans-stage.

Bootstraps and regtests ok on x86_64-linux-gnu/F21.

Ok, for trunk?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr58586_2.clog
Description: Binary data

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 76afd72..a43396c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -14063,10 +14063,15 @@ resolve_symbol (gfc_symbol *sym)
 
       if ((!a->save && !a->dummy && !a->pointer
 	   && !a->in_common && !a->use_assoc
-	   && (a->referenced || a->result)
-	   && !(a->function && sym != sym->result))
+	   && !a->result && !a->function)
 	  || (a->dummy && a->intent == INTENT_OUT && !a->pointer))
 	apply_default_init (sym);
+      else if (a->function && sym->result && a->access != ACCESS_PRIVATE
+	       && (sym->ts.u.derived->attr.alloc_comp
+		   || sym->ts.u.derived->attr.pointer_comp))
+	/* Mark the result symbol to be referenced, when it has allocatable
+	   components.  */
+	sym->result->attr.referenced = 1;
     }
 
   if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4c18920..0b63175 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2158,6 +2158,8 @@ build_function_decl (gfc_symbol * sym, bool global)
     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
 
   sym->backend_decl = fndecl;
+  if (sym == sym->result && !sym->result->backend_decl)
+    sym->result->backend_decl = result_decl;
 }
 
 
@@ -5898,8 +5900,21 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
     {
+      bool artificial_result_decl = false;
       tree result = get_proc_result (sym);
 
+      /* Make sure that a function returning an object with
+	 alloc/pointer_components always has a result, where at least
+	 the allocatable/pointer components are set to zero.  */
+      if (result == NULL_TREE && sym->attr.function
+	  && sym->ts.type == BT_DERIVED
+	  && (sym->ts.u.derived->attr.alloc_comp
+	      || sym->ts.u.derived->attr.pointer_comp))
+	{
+	  artificial_result_decl = true;
+	  result = gfc_get_fake_result_decl (sym, 0);
+	}
+
       if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
 	{
 	  if (sym->attr.allocatable && sym->attr.dimension == 0
@@ -5918,16 +5933,26 @@ gfc_generate_function_code (gfc_namespace * ns)
 							null_pointer_node));
 	    }
 	  else if (sym->ts.type == BT_DERIVED
-		   && sym->ts.u.derived->attr.alloc_comp
 		   && !sym->attr.allocatable)
 	    {
-	      rank = sym->as ? sym->as->rank : 0;
-	      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
-	      gfc_add_expr_to_block (&init, tmp);
+	      gfc_expr *init_exp;
+	      init_exp = gfc_default_initializer (&sym->ts);
+	      if (init_exp)
+		{
+		  tmp = gfc_trans_structure_assign (result, init_exp, 0);
+		  gfc_free_expr (init_exp);
+		  gfc_add_expr_to_block (&init, tmp);
+		}
+	      else if (sym->ts.u.derived->attr.alloc_comp)
+		{
+		  rank = sym->as ? sym->as->rank : 0;
+		  tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+		  gfc_add_expr_to_block (&init, tmp);
+		}
 	    }
 	}
 
-      if (result == NULL_TREE)
+      if (result == NULL_TREE || artificial_result_decl)
 	{
 	  /* TODO: move to the appropriate place in resolve.c.  */
 	  if (warn_return_type && sym == sym->result)
@@ -5937,7 +5962,7 @@ gfc_generate_function_code (gfc_namespace * ns)
 	  if (warn_return_type)
 	    TREE_NO_WARNING(sym->backend_decl) = 1;
 	}
-      else
+      if (result != NULL_TREE)
 	gfc_add_expr_to_block (&body, gfc_generate_return ());
     }
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9e6432f..2db7524 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1472,7 +1472,6 @@ realloc_lhs_warning (bt type, bool array, locus *where)
 }
 
 
-static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init);
 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
 						 gfc_expr *);
 
@@ -5344,8 +5343,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
         {
 	  int parm_rank;
-	  tmp = build_fold_indirect_ref_loc (input_location,
-					 parmse.expr);
+	  /* It is known the e returns a structure type with at least one
+	     allocatable component.  When e is a function, ensure that the
+	     function is called once only by using a temporary variable.  */
+	  if (e->expr_type == EXPR_FUNCTION)
+	    parmse.expr = gfc_evaluate_now_loc (input_location,
+						parmse.expr, &se->pre);
+
+	  if (fsym->attr.value)
+	    tmp = parmse.expr;
+	  else
+	    tmp = build_fold_indirect_ref_loc (input_location,
+					       parmse.expr);
+
 	  parm_rank = e->rank;
 	  switch (parm_kind)
 	    {
@@ -7136,7 +7146,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 
 /* Assign a derived type constructor to a variable.  */
 
-static tree
+tree
 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
 {
   gfc_constructor *c;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e2a1fea..3198c55 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -666,6 +666,9 @@ tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespe
 /* Generate code to call realloc().  */
 tree gfc_call_realloc (stmtblock_t *, tree, tree);
 
+/* Assign a derived type constructor to a variable.  */
+tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
+
 /* Generate code for an assignment, includes scalarization.  */
 tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
 
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03
new file mode 100644
index 0000000..28c0beb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03
@@ -0,0 +1,42 @@
+! { dg-do run }
+! { dg-options "-Wreturn-type" }
+!
+! Check that pr58586 is fixed now.
+! Based on a contribution by Vladimir Fuka
+! Contibuted by Andre Vehreschild
+
+program test_pr58586
+  implicit none
+
+  type :: a
+  end type
+
+  type :: c
+     type(a), allocatable :: a
+  end type
+
+  type :: b
+     integer, allocatable :: a
+  end type
+
+  ! These two are merely to check, if compilation works
+  call add(b())
+  call add(b(null()))
+
+  ! This needs to execute, to see whether the segfault at runtime is resolved
+  call add_c(c_init())
+
+contains
+
+  subroutine add (d)
+    type(b), value :: d
+  end subroutine
+
+  subroutine add_c (d)
+    type(c), value :: d
+  end subroutine
+
+  type(c) function c_init()  ! { dg-warning "not set" }
+  end function
+end program test_pr58586
+
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03
new file mode 100644
index 0000000..578df83
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03
@@ -0,0 +1,74 @@
+! { dg-do run }
+! { dg-options "-Wreturn-type" }
+!
+! Check that pr58586 is fixed now.
+! Based on a contribution by Vladimir Fuka
+! Contibuted by Andre Vehreschild
+
+module test_pr58586_mod
+  implicit none
+
+  type :: a
+  end type
+
+  type :: c
+     type(a), allocatable :: a
+  end type
+
+  type :: d
+  contains
+     procedure :: init => d_init
+  end type
+
+  type, extends(d) :: e
+  contains
+     procedure :: init => e_init
+  end type
+
+  type :: b
+     integer, allocatable :: a
+  end type
+
+contains
+
+  subroutine add (d)
+    type(b), value :: d
+  end subroutine
+
+  subroutine add_c (d)
+    type(c), value :: d
+  end subroutine
+
+  type(c) function c_init() ! { dg-warning "not set" }
+  end function
+
+  type(c) function d_init(this) ! { dg-warning "not set" }
+    class(d) :: this
+  end function
+
+  type(c) function e_init(this)
+    class(e) :: this
+    allocate (e_init%a)
+  end function
+end module test_pr58586_mod
+
+program test_pr58586
+  use test_pr58586_mod
+
+  class(d), allocatable :: od
+  class(e), allocatable :: oe
+  ! These two are merely to check, if compilation works
+  call add(b())
+  call add(b(null()))
+
+  ! This needs to execute, to see whether the segfault at runtime is resolved
+  call add_c(c_init())
+
+  allocate(od)
+  call add_c(od%init())
+  deallocate(od)
+  allocate(oe)
+  call add_c(oe%init())
+  deallocate(oe)
+end program
+