Skip to content

R
riscv-gcc-1
Commit ce1ff48e by Paul Thomas
Options

re PR fortran/69423 (Invalid optimization with deferred-length character) 

2016-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69423
	* trans-decl.c (create_function_arglist): Deferred character
	length functions, with and without declared results, address
	the passed reference type as '.result' and the local string
	length as '..result'.
	(gfc_null_and_pass_deferred_len): Helper function to null and
	return deferred string lengths, as needed.
	(gfc_trans_deferred_vars): Call it, thereby reducing repeated
	code, add call for deferred arrays and reroute pointer function
	results. Avoid using 'tmp' for anything other that a temporary
	tree by introducing 'type_of_array' for the arrayspec type.

2016-02-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/69423
	* gfortran.dg/deferred_character_15.f90 : New test.

From-SVN: r233589
parent bbf27208
Showing with 172 additions and 81 deletions
gcc/fortran/ChangeLog
2016-02-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69423
* trans-decl.c (create_function_arglist): Deferred character
length functions, with and without declared results, address
the passed reference type as '.result' and the local string
length as '..result'.
(gfc_null_and_pass_deferred_len): Helper function to null and
return deferred string lengths, as needed.
(gfc_trans_deferred_vars): Call it, thereby reducing repeated
code, add call for deferred arrays and reroute pointer function
results. Avoid using 'tmp' for anything other that a temporary
tree by introducing 'type_of_array' for the arrayspec type.
2015-02-16 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/69742
......
gcc/fortran/trans-decl.c
......@@ -2234,7 +2234,12 @@ create_function_arglist (gfc_symbol * sym)
PARM_DECL,
get_identifier (".__result"),
len_type);
if (!sym->ts.u.cl->length)
if (POINTER_TYPE_P (len_type))
{
sym->ts.u.cl->passed_length = length;
TREE_USED (length) = 1;
}
else if (!sym->ts.u.cl->length)
{
sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
......@@ -2271,13 +2276,6 @@ create_function_arglist (gfc_symbol * sym)
type = gfc_sym_type (arg);
arg->backend_decl = backend_decl;
type = build_reference_type (type);
if (POINTER_TYPE_P (len_type))
{
sym->ts.u.cl->passed_length = length;
sym->ts.u.cl->backend_decl =
build_fold_indirect_ref_loc (input_location, length);
}
}
}
......@@ -3917,6 +3915,62 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
/* Helper function to manage deferred string lengths. */
static tree
gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
locus *loc)
{
tree tmp;
/* Character length passed by reference. */
tmp = sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = fold_convert (gfc_charlen_type_node, tmp);
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
/* Zero the string length when entering the scope. */
gfc_add_modify (init, sym->ts.u.cl->backend_decl,
build_int_cst (gfc_charlen_type_node, 0));
else
{
tree tmp2;
tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
gfc_charlen_type_node,
sym->ts.u.cl->backend_decl, tmp);
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
tmp2 = build3_loc (input_location, COND_EXPR,
void_type_node, present, tmp2,
build_empty_stmt (input_location));
}
gfc_add_expr_to_block (init, tmp2);
}
gfc_restore_backend_locus (loc);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
{
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
gfc_charlen_type_node, tmp,
sym->ts.u.cl->backend_decl);
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
tmp = build3_loc (input_location, COND_EXPR,
void_type_node, present, tmp,
build_empty_stmt (input_location));
}
}
else
tmp = NULL_TREE;
return tmp;
}
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
......@@ -3966,8 +4020,20 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
{
tmp = NULL;
if (proc_sym->ts.deferred)
{
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&proc_sym->declared_at);
gfc_start_block (&init);
tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
else
gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
if (proc_sym->ts.deferred)
......@@ -3993,7 +4059,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* Pass back the string length on exit. */
tmp = proc_sym->ts.u.cl->backend_decl;
if (TREE_CODE (tmp) != INDIRECT_REF)
if (TREE_CODE (tmp) != INDIRECT_REF
&& proc_sym->ts.u.cl->passed_length)
{
tmp = proc_sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
......@@ -4072,21 +4139,21 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
else if (sym->attr.dimension || sym->attr.codimension
|| (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))
else if ((sym->attr.dimension || sym->attr.codimension
|| (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
{
bool is_classarray = IS_CLASS_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
array_type tmp;
array_type type_of_array;
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
tmp = as->type;
if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
tmp = AS_EXPLICIT;
switch (tmp)
type_of_array = as->type;
if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
type_of_array = AS_EXPLICIT;
switch (type_of_array)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
......@@ -4169,6 +4236,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
&& sym->attr.result)
{
gfc_start_block (&init);
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
break;
default:
......@@ -4183,6 +4259,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
continue;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
|| (sym->attr.pointer && sym->attr.result)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
{
......@@ -4190,6 +4267,12 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
tree descriptor = NULL_TREE;
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_start_block (&init);
if (!sym->attr.pointer)
{
/* Nullify and automatic deallocation of allocatable
scalars. */
e = gfc_lval_expr_from_sym (sym);
......@@ -4221,10 +4304,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
gfc_free_expr (e);
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_start_block (&init);
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
/* Nullify when entering the scope. */
......@@ -4241,62 +4320,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
gfc_add_expr_to_block (&init, tmp);
}
}
if ((sym->attr.dummy || sym->attr.result)
&& sym->ts.type == BT_CHARACTER
&& sym->ts.deferred)
{
/* Character length passed by reference. */
tmp = sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = fold_convert (gfc_charlen_type_node, tmp);
if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
/* Zero the string length when entering the scope. */
gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
build_int_cst (gfc_charlen_type_node, 0));
else
{
tree tmp2;
tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
gfc_charlen_type_node,
sym->ts.u.cl->backend_decl, tmp);
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
tmp2 = build3_loc (input_location, COND_EXPR,
void_type_node, present, tmp2,
build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&init, tmp2);
}
gfc_restore_backend_locus (&loc);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
{
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
gfc_charlen_type_node, tmp,
sym->ts.u.cl->backend_decl);
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
tmp = build3_loc (input_location, COND_EXPR,
void_type_node, present, tmp,
build_empty_stmt (input_location));
}
}
else
tmp = NULL_TREE;
}
&& sym->ts.deferred
&& sym->ts.u.cl->passed_length)
tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
else
gfc_restore_backend_locus (&loc);
/* Deallocate when leaving the scope. Nullifying is not
needed. */
if (!sym->attr.result && !sym->attr.dummy
if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
&& !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
......@@ -4313,6 +4349,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_free_expr (expr);
}
}
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
......@@ -4353,19 +4390,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->attr.dummy)
{
gfc_start_block (&init);
/* Character length passed by reference. */
tmp = sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = fold_convert (gfc_charlen_type_node, tmp);
gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
gfc_charlen_type_node, tmp,
sym->ts.u.cl->backend_decl);
else
tmp = NULL_TREE;
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
......@@ -4427,6 +4454,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
struct module_hasher : ggc_ptr_hash<module_htab_entry>
{
typedef const char *compare_type;
......
gcc/testsuite/ChangeLog
2016-02-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69423
* gfortran.dg/deferred_character_15.f90 : New test.
2016-02-20 Dominique d'Humieres <dominiq@lps.ens.fr>
PR fortran/57365
......
gcc/testsuite/gfortran.dg/deferred_character_15.f90 0 → 100644
! { dg-do run }
!
! Test the fix for PR69423.
!
! Contributed by Antony Lewis <antony@cosmologist.info>
!
program tester
character(LEN=:), allocatable :: S
S= test(2)
if (len(S) .ne. 4) call abort
if (S .ne. "test") call abort
if (allocated (S)) deallocate (S)
S= test2(2)
if (len(S) .ne. 4) call abort
if (S .ne. "test") call abort
if (allocated (S)) deallocate (S)
contains
function test(alen)
character(LEN=:), allocatable :: test
integer alen, i
do i = alen, 1, -1
test = 'test'
exit
end do
! This line would print nothing when compiled with -O1 and higher.
! print *, len(test),test
if (len(test) .ne. 4) call abort
if (test .ne. "test") call abort
end function test
function test2(alen) result (test)
character(LEN=:), allocatable :: test
integer alen, i
do i = alen, 1, -1
test = 'test'
exit
end do
! This worked before the fix.
! print *, len(test),test
if (len(test) .ne. 4) call abort
if (test .ne. "test") call abort
end function test2
end program tester
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment