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

[Andre Vehreschild <vehre at gmx dot de>]

Hi,

attached is the most recent version of the patch for 58586. It adapts to
recent trunk and addresses the caveats so far, i.e. the testcases in the
comments now compile and run again w/o errors.

Bootstraps and regtests fine on x86_64-linux-gnu/f21.

Comments?

- Andre

On Fri, 8 May 2015 16:11:11 +0200
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi,
> 
> so attached is a quick and dirty solution for the allocatable return value
> problem. I personally don't like it. It is making a special case from the
> assign a function result to a variable. May be you have a better idea how to
> do this in gfortran style.
> 
> - Andre
> 
> 
> On Fri, 8 May 2015 15:31:46 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
> 
> > Hi Mikael,
> > 
> > > > ?? I don't get you there? What do you mean? Do you think the
> > > > alloc_comp_class_3/4.* are not correctly testing the issue? Any idea of
> > > > how to test this better? I mean the pr is about this artificial
> > > > constructs. I merely struck it in search of a pr about allocatable
> > > > components. 
> > > 
> > > I was talking about the bug you found with t_init above.  :-)
> > > the compiler is not ready to accept that function in a testcase.
> > > The alloc_omp_class_3/4 are fine.
> > 
> > Oh, sorry, I misunderstood you there. Now let's see, where that one is
> > hiding.
> > 
> > - Andre
> 
> 


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

Attachment: pr58586_4.clog
Description: Text document

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fc11d23..e1b5762 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -14094,10 +14094,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..f9a91c6 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5896,9 +5896,33 @@ gfc_generate_function_code (gfc_namespace * ns)
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 
-  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
+  if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
+      || (sym->result && sym->result != sym
+	  && sym->result->ts.type == BT_DERIVED
+	  && sym->result->ts.u.derived->attr.alloc_comp))
     {
+      bool artificial_result_decl = false;
       tree result = get_proc_result (sym);
+      gfc_symbol *rsym = sym == sym->result ? sym : sym->result;
+
+      /* 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->result->ts.type == BT_DERIVED
+	       && (sym->attr.allocatable
+		   || sym->attr.pointer
+		   || sym->result->ts.u.derived->attr.alloc_comp
+		   || sym->result->ts.u.derived->attr.pointer_comp))
+	      || (sym->result->ts.type == BT_CLASS
+		  && (CLASS_DATA (sym)->attr.allocatable
+		      || CLASS_DATA (sym)->attr.class_pointer
+		      || CLASS_DATA (sym->result)->attr.alloc_comp
+		      || CLASS_DATA (sym->result)->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)
 	{
@@ -5918,16 +5942,30 @@ 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;
+	      /* Arrays are not initialized using the default initializer of
+		 their elements.  Therefore only check if a default
+		 initializer is available when the result is scalar.  */
+	      init_exp = rsym->as ? NULL : gfc_default_initializer (&rsym->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 (rsym->ts.u.derived->attr.alloc_comp)
+		{
+		  rank = rsym->as ? rsym->as->rank : 0;
+		  tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result,
+						rank);
+		  gfc_prepend_expr_to_block (&body, 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 +5975,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 710bdcf..048d16e 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 *);
 
@@ -5329,12 +5328,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
 	    && e->ts.u.derived->attr.alloc_comp
 	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
-	    && e->expr_type != EXPR_VARIABLE && !e->rank
-	    && e->expr_type != EXPR_STRUCTURE)
+	    && 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 (!DECL_P (parmse.expr))
+	    parmse.expr = gfc_evaluate_now_loc (input_location,
+						parmse.expr, &se->pre);
+
+	  if (fsym && fsym->attr.value)
+	    tmp = parmse.expr;
+	  else
+	    tmp = build_fold_indirect_ref_loc (input_location,
+					       parmse.expr);
+
 	  parm_rank = e->rank;
 	  switch (parm_kind)
 	    {
@@ -7137,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;
@@ -7450,7 +7459,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       if (expr->ts.type == BT_CHARACTER
 	  && expr->expr_type != EXPR_FUNCTION)
 	gfc_conv_string_parameter (se);
-      else
+     else
 	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 
       return;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 570b5b8..f5d4d20 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -669,6 +669,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..0753e33
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_3.f03
@@ -0,0 +1,55 @@
+! { 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
+
+  type :: t
+    integer, allocatable :: comp
+  end type
+  type :: u
+    type(t), allocatable :: comp
+  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())
+
+  call sub(u())
+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
+
+  subroutine sub(d)
+    type(u), value :: d
+  end subroutine
+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..e4c796e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_class_4.f03
@@ -0,0 +1,104 @@
+! { 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
+
+  type t
+    integer :: i = 5
+  end type
+
+contains
+
+  subroutine add (d)
+    type(b), value :: d
+  end subroutine
+
+  subroutine add_c (d)
+    type(c), value :: d
+  end subroutine
+
+  subroutine add_class_c (d)
+    class(c), value :: d
+  end subroutine
+
+  subroutine add_t (d)
+    type(t), value :: d
+  end subroutine
+
+  type(c) function c_init() ! { dg-warning "not set" }
+  end function
+
+  class(c) function c_init2() ! { dg-warning "not set" }
+    allocatable :: c_init2
+  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
+
+  type(t) function t_init() ! { dg-warning "not set" }
+    allocatable :: t_init
+  end function
+
+  type(t) function static_t_init() ! { dg-warning "not set" }
+  end function
+end module test_pr58586_mod
+
+program test_pr58586
+  use test_pr58586_mod
+
+  class(d), allocatable :: od
+  class(e), allocatable :: oe
+  type(t), allocatable :: temp
+
+  ! 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())
+  call add_class_c(c_init2())
+
+  call add_t(static_t_init())
+  temp = t_init() ! <-- This derefs a null-pointer currently
+  if (allocated (temp)) call abort()
+
+  allocate(od)
+  call add_c(od%init())
+  deallocate(od)
+  allocate(oe)
+  call add_c(oe%init())
+  deallocate(oe)
+end program
+