From: Andre Vehreschild <vehre@gmx.de>
To: GCC-Patches-ML <gcc-patches@gcc.gnu.org>,
GCC-Fortran-ML <fortran@gcc.gnu.org>
Subject: Re: [Ping, Patch, Fortran, PR58586, v5] ICE with derived type with allocatable component passed by value
Date: Fri, 03 Jul 2015 09:29:00 -0000 [thread overview]
Message-ID: <20150703112900.1508b419@vepi2> (raw)
In-Reply-To: <20150519160137.05580a36@vepi2>
[-- Attachment #1: Type: text/plain, Size: 984 bytes --]
Ping!
Version increment only to reflect rebasing on current trunk.
Bootstraps and regtests fine on x86_64-linux-gnu/f21.
I am tempted to follow Paul's method of setting a deadline for objections. Else
I will commit the patch next Friday (just kidding). I am more interested in
a review. The patch now lives in my code base for several months and is used to
compile a rather sophisticated fortran code without issues. So I expect no big
trouble in trunk given that the patch addresses a rather seldomly (;-)) used
construct.
Ok for trunk?
Regards,
Andre
On Tue, 19 May 2015 16:01:37 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> 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
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr58586_5.clog --]
[-- Type: application/octet-stream, Size: 1062 bytes --]
gcc/testsuite/ChangeLog:
2015-07-03 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/alloc_comp_class_3.f03: New test.
* gfortran.dg/alloc_comp_class_4.f03: New test.
gcc/fortran/ChangeLog:
2015-07-03 Andre Vehreschild <vehre@gmx.de>
PR fortran/58586
* resolve.c (resolve_symbol): Non-private functions in modules
with allocatable or pointer components are marked referenced
now. Furthermore is the default init especially for those
components now done in gfc_conf_procedure_call preventing
duplicate code.
* trans-decl.c (gfc_generate_function_code): Generate a fake
result decl for functions returning an object with allocatable
components and initialize them.
* trans-expr.c (gfc_conv_procedure_call): For value typed trees
use the tree without indirect ref. And for non-decl trees
add a temporary variable to prevent evaluating the tree
multiple times (prevent multiple function evaluations).
* trans.h: Made gfc_trans_structure_assign () protoype
available, which is now needed by trans-decl.c:gfc_generate_
function_code(), too.
[-- Attachment #3: pr58586_5.patch --]
[-- Type: text/x-patch, Size: 9954 bytes --]
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index efafabc..d16bf13 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -14083,10 +14083,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 b4f75ba..aec2018 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5885,9 +5885,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)
{
@@ -5907,16 +5931,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)
@@ -5926,7 +5964,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 7747a67..195f7a4 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1465,7 +1465,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 *);
@@ -5340,8 +5339,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 (!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)
{
@@ -7158,7 +7168,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;
@@ -7471,7 +7481,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 e618088..f7cf5f0 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
+
next prev parent reply other threads:[~2015-07-03 9:29 UTC|newest]
Thread overview: 19+ messages / expand[flat|nested] mbox.gz Atom feed top
2015-04-15 18:03 [Patch, Fortran, PR58586, v1] " Andre Vehreschild
2015-04-19 10:01 ` Mikael Morin
2015-04-23 18:01 ` [Patch, Fortran, PR58586, v2] " Andre Vehreschild
2015-04-24 8:37 ` Andre Vehreschild
2015-04-26 10:23 ` Mikael Morin
2015-05-05 9:00 ` [Patch, Fortran, PR58586, v3] " Andre Vehreschild
2015-05-07 10:15 ` Mikael Morin
2015-05-08 10:54 ` Andre Vehreschild
2015-05-08 13:21 ` Mikael Morin
2015-05-08 13:31 ` Andre Vehreschild
2015-05-08 14:11 ` Andre Vehreschild
2015-05-19 14:02 ` [Patch, Fortran, PR58586, v4] " Andre Vehreschild
2015-07-03 9:29 ` Andre Vehreschild [this message]
2015-07-04 16:25 ` [Ping, Patch, Fortran, PR58586, v5] " Steve Kargl
2015-07-04 19:20 ` Andre Vehreschild
2015-07-05 16:15 ` Steve Kargl
2015-07-05 17:48 ` Paul Richard Thomas
2015-07-05 18:14 ` Steve Kargl
2015-07-06 10:32 ` [commited, " Andre Vehreschild
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20150703112900.1508b419@vepi2 \
--to=vehre@gmx.de \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).