This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch,Fortran] PR 41777 - fix attribute usage for generics
- From: Tobias Burnus <burnus at net-b dot de>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Thu, 29 Oct 2009 11:51:26 +0100
- Subject: [patch,Fortran] PR 41777 - fix attribute usage for generics
There seem to be multiple issues with generic functions as at
several places the generic symbols attributes (expr->symtree->n.sym)
and not the one of the specific (expr->value.functions.esym) is used.
The attached patch fixes some of those problems, but more remain as
the PR shows; in particular, the program in comment 0 of the PR
still does not work.
With regards to wrong-code, the issue is mostly whether the address
of the pointer or of the pointer target is used.
Bootstrapped and regtested on x86-64-linux.
OK for the trunk? What do you think about 4.4/4.3 backports?
Tobias
2009-10-29 Tobias Burnus <burnus@net-b.de>
PR fortran/41777
* trans-expr.c (gfc_conv_procedure_call,gfc_conv_expr_reference):
Use for generic EXPR_FUNCTION the attributes of the specific
function.
2009-10-29 Tobias Burnus <burnus@net-b.de>
PR fortran/41777
gfortran.dg/associated_target_3.f90: New testcase.
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 153642)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2870,8 +2870,11 @@ gfc_conv_procedure_call (gfc_se * se, gf
through arg->name. */
conv_arglist_function (&parmse, arg->expr, arg->name);
else if ((e->expr_type == EXPR_FUNCTION)
- && e->symtree->n.sym->attr.pointer
- && fsym && fsym->attr.target)
+ && ((e->value.function.esym
+ && e->value.function.esym->result->attr.pointer)
+ || (!e->value.function.esym
+ && e->symtree->n.sym->attr.pointer))
+ && fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
@@ -4368,8 +4371,12 @@ gfc_conv_expr_reference (gfc_se * se, gf
}
if (expr->expr_type == EXPR_FUNCTION
- && expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.dimension)
+ && ((expr->value.function.esym
+ && expr->value.function.esym->result->attr.pointer
+ && !expr->value.function.esym->result->attr.dimension)
+ || (!expr->value.function.esym
+ && expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.dimension)))
{
se->want_pointer = 1;
gfc_conv_expr (se, expr);
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 153642)
+++ gcc/fortran/check.c (working copy)
@@ -599,10 +599,8 @@ gfc_check_associated (gfc_expr *pointer,
where = &pointer->where;
- if (pointer->expr_type == EXPR_VARIABLE)
- attr1 = gfc_variable_attr (pointer, NULL);
- else if (pointer->expr_type == EXPR_FUNCTION)
- attr1 = pointer->symtree->n.sym->attr;
+ if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION)
+ attr1 = gfc_expr_attr (pointer);
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
@@ -624,10 +622,8 @@ gfc_check_associated (gfc_expr *pointer,
if (target->expr_type == EXPR_NULL)
goto null_arg;
- if (target->expr_type == EXPR_VARIABLE)
- attr2 = gfc_variable_attr (target, NULL);
- else if (target->expr_type == EXPR_FUNCTION)
- attr2 = target->symtree->n.sym->attr;
+ if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
+ attr2 = gfc_expr_attr (target);
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
Index: gcc/testsuite/gfortran.dg/associated_target_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/associated_target_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/associated_target_3.f90 (revision 0)
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! PR fortran/41777
+!
+module m
+type t2
+ integer :: i
+end type t2
+interface f
+ module procedure f2
+end interface f
+contains
+function f2(a)
+ type(t2), pointer :: f2,a
+ f2 => a
+end function f2
+end module m
+
+use m
+implicit none
+type(t2), pointer :: a
+allocate(a)
+if (.not. associated(a,f(a))) call abort()
+call cmpPtr(a,f2(a))
+call cmpPtr(a,f(a))
+deallocate(a)
+contains
+ subroutine cmpPtr(a,b)
+ type(t2), pointer :: a,b
+! print *, associated(a,b)
+ if (.not. associated (a, b)) call abort()
+ end subroutine cmpPtr
+end
+
+! { dg-final { cleanup-modules "m" } }