This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR19546 - References to parent function results.
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Jakub Jelinek <jakub at redhat dot com>
- Cc: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 14 Feb 2006 23:30:56 +0100
- Subject: [Patch, fortran] PR19546 - References to parent function results.
:ADDPATCH fortran:
Jakub,
I have addressed this to you because I have been very well aware of wading
around in code that you created and are much more familiar with than me.
Regardless of your status as a reviewer, I would very much like your opinion
about this patch. Some feedback on the OMP aspect, mentioned below, would
be appreciated as well.
This is a patch to fix PR19546, in which references to the return value of
a parent function cause an ICE.
The main part of the patch is found in trans-expr.c (gfc_conv_variable) and
trans-decl.c (gfc_get_fake_result_decl). The rest of the patch applies the
modifications that result from the main event. The detection of a
reference
to a parent return value is done in gfc_conv_variable and flagged for calls
to gfc_get_fake_result_decl. The current_fake_result_decl is supplemented by
parent_fake_result_decl and the switching between the two is done in
gfc_get_fake_result_decl, using a new argument, parent_flag.
In the longer run, a more sophisticated signaling of the scope, than the
parent_flag will have to be put in place, together with retrieval of the
function declarations for each scope, enabling nesting of contained
functions
for F2003. In the mean time, this patch is entirely sufficient for F95.
The first testcase is a more developed version of F-X's reduced testcase in
the PR. It checks that a scalar reference to a parent result works
correctly
and that the caller sees the intended result. The second test case is more
or less similar but checks character return values. The third checks that
entry references are correctly handled. The fourth checks that module refs
work.
It should be noted that alternate entries to module procedures are broken;
The attached test.f90 generates -
Internal Error at (1):
insert_bbt(): Duplicate key found!
I recall this as being an existing PR but I am just too tired to check this
tonight.
I rather think that gfc_trans_omp_variable can have the same treatment as
gfc_conv_variable but I do not feel at all competent to judge if references
to parent results is compatible with OMP and still less to write the test
cases. I have therefore added a TODO to this function so that Jakub can
deal with it when his workload allows.
Regtested on FC3/Athlon. OK for trunk?
Paul
PS Congratulations on the gomp patch - that's a great bit of work.
2005-02-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/19546
* trans-expr.c (gfc_conv_variable): Detect reference to parent result,
store current_function_decl, replace with parent, whilst calls are
made to gfc_get_fake_result_decl, and restore afterwards. Signal this
to gfc_get_fake_result_decl with a new argument, parent_flag.
* trans-stmt.c (gfc_trans_return): gfc_get_fake_result_decl 2nd arg
is set to zero.
* trans.h: Add parent_flag to gfc_get_fake_result_decl prototype.
* trans-decl.c (gfc_get_fake_result_decl): On parent_flag, being set,
add decl to parent function. Replace refs to current_fake_result_decl
with refs to this_result_decl.
(gfc_generate_function_code): Null parent_fake_result_decl before the
translation of code for contained procedures. Set parent_flag to zero
in call to gfc_get_fake_result_decl.
* trans-intrinsic.c (gfc_conv_intrinsic_len): The same.
2005-02-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/19546
* gfortran.dg/parent_result_ref_1.f90: New test.
* gfortran.dg/parent_result_ref_2.f90: New test.
* gfortran.dg/parent_result_ref_3.f90: New test.
* gfortran.dg/parent_result_ref_4.f90: New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 110986)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 296,301 ****
--- 296,306 ----
{
gfc_ref *ref;
gfc_symbol *sym;
+ tree parent_decl;
+ int parent_flag;
+ bool return_value;
+ bool alternate_entry;
+ bool entry_master;
sym = expr->symtree->n.sym;
if (se->ss != NULL)
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 317,348 ****
se->expr = gfc_get_symbol_decl (sym);
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
! if (se->expr == current_function_decl && sym->attr.function
! && (sym->result == sym))
! se_expr = gfc_get_fake_result_decl (sym);
/* Similarly for alternate entry points. */
! else if (sym->attr.function && sym->attr.entry
! && (sym->result == sym)
! && sym->ns->proc_name->backend_decl == current_function_decl)
{
gfc_entry_list *el = NULL;
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
! se_expr = gfc_get_fake_result_decl (sym);
break;
}
}
! else if (sym->attr.result
! && sym->ns->proc_name->backend_decl == current_function_decl
! && sym->ns->proc_name->attr.entry_master
! && !gfc_return_by_reference (sym->ns->proc_name))
! se_expr = gfc_get_fake_result_decl (sym);
if (se_expr)
se->expr = se_expr;
--- 322,372 ----
se->expr = gfc_get_symbol_decl (sym);
+ /* Deal with references to a parent results or entries by storing
+ the current_function_decl and moving to the parent_decl. */
+ parent_flag = 0;
+
+ return_value = sym->attr.function && sym->result == sym;
+ alternate_entry = sym->attr.function && sym->attr.entry
+ && sym->result == sym;
+ entry_master = sym->attr.result
+ && sym->ns->proc_name->attr.entry_master
+ && !gfc_return_by_reference (sym->ns->proc_name);
+ parent_decl = DECL_CONTEXT (current_function_decl);
+
+ if ((se->expr == parent_decl && return_value)
+ || (sym->ns && sym->ns->proc_name
+ && sym->ns->proc_name->backend_decl == parent_decl
+ && (alternate_entry || entry_master)))
+ parent_flag = 1;
+ else
+ parent_flag = 0;
+
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
! if (sym->attr.function && sym->result == sym
! && (se->expr == current_function_decl || parent_flag))
! se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
! else if (alternate_entry
! && (sym->ns->proc_name->backend_decl == current_function_decl
! || parent_flag))
{
gfc_entry_list *el = NULL;
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
! se_expr = gfc_get_fake_result_decl (sym, parent_flag);
break;
}
}
! else if (entry_master
! && (sym->ns->proc_name->backend_decl == current_function_decl
! || parent_flag))
! se_expr = gfc_get_fake_result_decl (sym, parent_flag);
if (se_expr)
se->expr = se_expr;
Index: gcc/fortran/trans-openmp.c
===================================================================
*** gcc/fortran/trans-openmp.c (revision 110986)
--- gcc/fortran/trans-openmp.c (working copy)
*************** gfc_trans_add_clause (tree node, tree ta
*** 182,187 ****
--- 182,190 ----
return node;
}
+ /* TODO make references to parent function results, as done in
+ gfc_conv_variable. */
+
static tree
gfc_trans_omp_variable (gfc_symbol *sym)
{
*************** gfc_trans_omp_variable (gfc_symbol *sym)
*** 191,197 ****
Self recursive functions must have an explicit return value. */
if (t == current_function_decl && sym->attr.function
&& (sym->result == sym))
! t = gfc_get_fake_result_decl (sym);
/* Similarly for alternate entry points. */
else if (sym->attr.function && sym->attr.entry
--- 194,200 ----
Self recursive functions must have an explicit return value. */
if (t == current_function_decl && sym->attr.function
&& (sym->result == sym))
! t = gfc_get_fake_result_decl (sym, 0);
/* Similarly for alternate entry points. */
else if (sym->attr.function && sym->attr.entry
*************** gfc_trans_omp_variable (gfc_symbol *sym)
*** 203,209 ****
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
! t = gfc_get_fake_result_decl (sym);
break;
}
}
--- 206,212 ----
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
! t = gfc_get_fake_result_decl (sym, 0);
break;
}
}
*************** gfc_trans_omp_variable (gfc_symbol *sym)
*** 212,218 ****
&& sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name))
! t = gfc_get_fake_result_decl (sym);
return t;
}
--- 215,221 ----
&& sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name))
! t = gfc_get_fake_result_decl (sym, 0);
return t;
}
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 110986)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_return (gfc_code * code ATTRIB
*** 316,322 ****
in a subroutine and current_fake_result_decl has already
been generated. */
! result = gfc_get_fake_result_decl (NULL);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
--- 316,322 ----
in a subroutine and current_fake_result_decl has already
been generated. */
! result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 110986)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_build_label_decl (tree);
*** 361,367 ****
/* Return the decl used to hold the function return value.
Do not use if the function has an explicit result variable. */
! tree gfc_get_fake_result_decl (gfc_symbol *);
/* Get the return label for the current function. */
tree gfc_get_return_label (void);
--- 361,367 ----
/* Return the decl used to hold the function return value.
Do not use if the function has an explicit result variable. */
! tree gfc_get_fake_result_decl (gfc_symbol *, int);
/* Get the return label for the current function. */
tree gfc_get_return_label (void);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 110986)
--- gcc/fortran/trans-decl.c (working copy)
*************** Software Foundation, 51 Franklin Street,
*** 50,55 ****
--- 50,56 ----
/* Holds the result of the function if no result variable specified. */
static GTY(()) tree current_fake_result_decl;
+ static GTY(()) tree parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
*************** gfc_create_function_decl (gfc_namespace
*** 1730,1757 ****
create_function_arglist (ns->proc_name);
}
! /* Return the decl used to hold the function return value. */
tree
! gfc_get_fake_result_decl (gfc_symbol * sym)
{
! tree decl, length;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (sym
! && sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
tree t = NULL, var;
! if (current_fake_result_decl != NULL)
! for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
break;
if (t)
return TREE_VALUE (t);
! decl = gfc_get_fake_result_decl (sym->ns->proc_name);
if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
--- 1731,1779 ----
create_function_arglist (ns->proc_name);
}
! /* Return the decl used to hold the function return value. If
! parent_flag is set, the context is the parent_scope*/
tree
! gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
{
! tree decl;
! tree length;
! tree this_fake_result_decl;
! tree this_function_decl;
char name[GFC_MAX_SYMBOL_LEN + 10];
+ if (parent_flag)
+ {
+ this_fake_result_decl = parent_fake_result_decl;
+ this_function_decl = DECL_CONTEXT (current_function_decl);
+ }
+ else
+ {
+ this_fake_result_decl = current_fake_result_decl;
+ this_function_decl = current_function_decl;
+ }
+
if (sym
! && sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
tree t = NULL, var;
! if (this_fake_result_decl != NULL)
! for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
break;
if (t)
return TREE_VALUE (t);
! decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
!
! if (parent_flag)
! this_fake_result_decl = parent_fake_result_decl;
! else
! this_fake_result_decl = current_fake_result_decl;
!
if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
*************** gfc_get_fake_result_decl (gfc_symbol * s
*** 1766,1783 ****
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
! var = gfc_create_var (TREE_TYPE (decl), sym->name);
! GFC_DECL_RESULT (var) = 1;
SET_DECL_VALUE_EXPR (var, decl);
DECL_HAS_VALUE_EXPR_P (var) = 1;
! TREE_CHAIN (current_fake_result_decl)
! = tree_cons (get_identifier (sym->name), var,
! TREE_CHAIN (current_fake_result_decl));
return var;
}
! if (current_fake_result_decl != NULL_TREE)
! return TREE_VALUE (current_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
--- 1788,1811 ----
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
!
! var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
! if (parent_flag)
! gfc_add_decl_to_parent_function (var);
! else
! gfc_add_decl_to_function (var);
!
SET_DECL_VALUE_EXPR (var, decl);
DECL_HAS_VALUE_EXPR_P (var) = 1;
!
! TREE_CHAIN (this_fake_result_decl)
! = tree_cons (get_identifier (sym->name), var,
! TREE_CHAIN (this_fake_result_decl));
return var;
}
! if (this_fake_result_decl != NULL_TREE)
! return TREE_VALUE (this_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
*************** gfc_get_fake_result_decl (gfc_symbol * s
*** 1797,1805 ****
if (gfc_return_by_reference (sym))
{
! decl = DECL_ARGUMENTS (current_function_decl);
! if (sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master)
decl = TREE_CHAIN (decl);
--- 1825,1833 ----
if (gfc_return_by_reference (sym))
{
! decl = DECL_ARGUMENTS (this_function_decl);
! if (sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master)
decl = TREE_CHAIN (decl);
*************** gfc_get_fake_result_decl (gfc_symbol * s
*** 1810,1819 ****
else
{
sprintf (name, "__result_%.20s",
! IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
decl = build_decl (VAR_DECL, get_identifier (name),
! TREE_TYPE (TREE_TYPE (current_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
--- 1838,1847 ----
else
{
sprintf (name, "__result_%.20s",
! IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
decl = build_decl (VAR_DECL, get_identifier (name),
! TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
*************** gfc_get_fake_result_decl (gfc_symbol * s
*** 1823,1832 ****
layout_decl (decl, 0);
! gfc_add_decl_to_function (decl);
}
! current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
--- 1851,1866 ----
layout_decl (decl, 0);
! if (parent_flag)
! gfc_add_decl_to_parent_function (decl);
! else
! gfc_add_decl_to_function (decl);
}
! if (parent_flag)
! parent_fake_result_decl = build_tree_list (NULL, decl);
! else
! current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
*************** gfc_generate_function_code (gfc_namespac
*** 2821,2832 ****
/* Translate COMMON blocks. */
gfc_trans_common (ns);
gfc_generate_contained_functions (ns);
generate_local_vars (ns);
! /* Will be created as needed. */
! current_fake_result_decl = NULL_TREE;
current_function_return_label = NULL;
/* Now generate the code for the body of this function. */
--- 2855,2878 ----
/* Translate COMMON blocks. */
gfc_trans_common (ns);
+ /* Null the parent fake result declaration if this namespace is
+ a module function or an external procedures. */
+ if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ || ns->parent == NULL)
+ parent_fake_result_decl = NULL_TREE;
+
gfc_generate_contained_functions (ns);
generate_local_vars (ns);
! /* Keep the parent fake result declaration in module functions
! or external procedures. */
! if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
! || ns->parent == NULL)
! current_fake_result_decl = parent_fake_result_decl;
! else
! current_fake_result_decl = NULL_TREE;
!
current_function_return_label = NULL;
/* Now generate the code for the body of this function. */
*************** gfc_generate_function_code (gfc_namespac
*** 2888,2894 ****
&& sym->attr.subroutine)
{
tree alternate_return;
! alternate_return = gfc_get_fake_result_decl (sym);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
--- 2934,2940 ----
&& sym->attr.subroutine)
{
tree alternate_return;
! alternate_return = gfc_get_fake_result_decl (sym, 0);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 110986)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_len (gfc_se * se, gfc
*** 2101,2107 ****
decl = gfc_get_symbol_decl (sym);
if (decl == current_function_decl && sym->attr.function
&& (sym->result == sym))
! decl = gfc_get_fake_result_decl (sym);
len = sym->ts.cl->backend_decl;
gcc_assert (len);
--- 2101,2107 ----
decl = gfc_get_symbol_decl (sym);
if (decl == current_function_decl && sym->attr.function
&& (sym->result == sym))
! decl = gfc_get_fake_result_decl (sym, 0);
len = sym->ts.cl->backend_decl;
gcc_assert (len);
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! From the testcase of Francois-Xavier Coudert/Tobias Schlueter
!
function f()
integer :: f
f = 42
call sub ()
if (f.eq.1) f = f + 1
contains
subroutine sub
if (f.eq.42) f = f - 41
end subroutine sub
end function f
integer, external :: f
if (f ().ne.2) call abort ()
end
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! This case tests character results.
!
function f()
character(4) :: f
f = "efgh"
call sub ()
if (f.eq."iklm") f = "abcd"
call sub ()
contains
subroutine sub
f = "wxyz"
if (f.eq."efgh") f = "iklm"
end subroutine sub
end function f
function g() ! { dg-warning "is obsolescent in fortran 95" }
character(*) :: g
g = "efgh"
call sub ()
if (g.eq."iklm") g = "ABCD"
call sub ()
contains
subroutine sub
g = "WXYZ"
if (g.eq."efgh") g = "iklm"
end subroutine sub
end function g
character(4), external :: f, g
if (f ().ne."wxyz") call abort ()
if (g ().ne."WXYZ") call abort ()
end
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! Check that parent alternate entry results can be referenced.
!
function f()
integer :: f, g
f = 42
call sub1 ()
if (f.eq.1) f = 2
return
entry g()
g = 99
call sub2 ()
if (g.eq.77) g = 33
contains
subroutine sub1
if (f.eq.42) f = 1
end subroutine sub1
subroutine sub2
if (g.eq.99) g = g - 22
end subroutine sub2
end function f
integer, external :: f, g
if (f ().ne.2) call abort ()
if (g ().ne.33) call abort ()
end
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! Check that parent function results can be referenced in modules.
!
module m
contains
function f()
integer :: f
f = 42
call sub ()
if (f.eq.1) f = f + 1
contains
subroutine sub
if (f.eq.42) f = f - 41
end subroutine sub
end function f
end module m
use m
if (f ().ne.2) call abort ()
end
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! Check that parent function results can be referenced in modules.
!
module m
contains
function f()
integer :: f, g
f = 42
return
entry g()
g = 99
end function f
end module m
use m
if (f ().ne.42) call abort ()
if (g ().ne.99) call abort ()
end