This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran, PR58586, v3] ICE with derived type with allocatable component passed by value
- From: Andre Vehreschild <vehre at gmx dot de>
- To: Mikael Morin <mikael dot morin at sfr dot fr>
- Cc: GCC-Patches-ML <gcc-patches at gcc dot gnu dot org>, GCC-Fortran-ML <fortran at gcc dot gnu dot org>
- Date: Fri, 8 May 2015 12:54:44 +0200
- Subject: Re: [Patch, Fortran, PR58586, v3] ICE with derived type with allocatable component passed by value
- Authentication-results: sourceware.org; auth=none
- References: <20150415200304 dot 7101aca9 at gmx dot de> <55337CF3 dot 9010002 at sfr dot fr> <20150423200052 dot 2e7a1311 at gmx dot de> <553CBC80 dot 2050208 at sfr dot fr> <20150505110026 dot 7ecbc229 at gmx dot de> <554B3B23 dot 3050800 at sfr dot fr>
Hi Mikael,
thanks for the review. I still have some questions/remarks before commiting:
On Thu, 07 May 2015 12:14:59 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:
<snip>
> > @@ -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;
>
> Something is seriously misbehaving if the condition is true, and setting
> sym->backend_decl to result_decl doesn't seem any better than keeping it
> NULL.
> So, please remove this change
Did that. I think this was a relic from the start of me trying to understand
what was the issue and how to fix it. Later I didn't check, if it was still
necessary. Sorry for that.
> > @@ -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);
> > + }
>
> I expect the "fake" result decl to be needed in more cases.
> For example, if type is BT_CLASS.
> Here is a variant of alloc_comp_class_4.f03:c_init for such a case.
>
> class(c) function c_init2()
> allocatable :: c_init2
> end function
>
> or even without class:
>
> type(t) function t_init()
> allocatable :: t_init
> end function
>
> for some any type t.
>
> So, remove the check for alloc_comp/pointer_comp and permit BT_CLASS.
> One minor thing, check sym->result's type and attribute instead of sym's
> here. It should not make a difference, but I think it's more correct.
I am d'accord with checking sym->result, but I am not happy with removing the
checks for alloc_comp|pointer_comp. When I got you right there, you propose the
if to be like this:
if (result == NULL_TREE && sym->attr.function
&& (sym->result->ts.type == BT_DERIVED
|| sym->result->ts.type == BT_CLASS))
Removing the attribute checks means to initialize every derived/class type
result, which may change the semantics of the code more than intented. Look for
example at this code
type t
integer :: i = 5
end type
type(t) function static_t_init()
end function
When one compiles this code with -Wreturn-type, then the warning of an
uninitialized return value is issued at the function declaration. Nevertheless
the result of static_t_init is validly initialized and i is 5. This may
confuse users.
I therefore came to the very ugly solution to make this:
if (result == NULL_TREE && sym->attr.function
&& ((sym->result->ts.type == BT_DERIVED
&& (sym->results->attr.allocatable
|| 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->result)->attr.allocatable
|| CLASS_DATA (sym->result)->attr.alloc_comp
|| CLASS_DATA (sym->result)->attr.pointer_comp))))
(I am not yet sure, whether the pointer attribute needs to be added to.) With
the code above the result of static_t_init is not initialized with all the
consequences.
So what do you propose to do here?
Btw, I think I found an additional bug during testing:
type(t) function t_init()
allocatable :: t_init
end function
when called by:
type(t), allocatable :: temp
temp = t_init()
a segfault occurs, because the result of t_init() is NULL, which is
dereferenced by the caller in this pseudo-code:
if (temp != 0B) goto L.12;
temp = (struct t *) __builtin_malloc (4);
L.12:;
*temp = *t_init (); <-- This obviously is problematic.
> The rest looks good.
> The patch is OK with the suggested changes above. Thanks.
> I don't think the test functions above work well enough to be
> incorporated in a testcase for now.
?? 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.
Attached is a version of the patch that I currently use. Note the testcase
alloc_comp_class_4.f03 fails currently, because of the error noted above in
line 94.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2ac4689..72df35e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -14093,10 +14093,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..bcafd8c5 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5898,8 +5898,26 @@ 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->result->ts.type == BT_DERIVED
+ && (sym->result->attr.allocatable
+ || 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->result)->attr.allocatable
+ || 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)
{
if (sym->attr.allocatable && sym->attr.dimension == 0
@@ -5918,16 +5936,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 +5965,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 4bbd685..16e584a 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 *);
@@ -5341,12 +5340,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;
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..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
+