OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/63733 ([OOP] wrong resolution for OPERATOR generics) 

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/63733
	* interface.c (gfc_extend_expr): Look for type-bound operators before
	non-typebound ones.

2015-01-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/63733
	* gfortran.dg/typebound_operator_20.f90: New.

From-SVN: r219440
This commit is contained in:
Janus Weil 2015-01-11 23:00:06 +01:00
parent c34d453f05
commit 517d78beb7
4 changed files with 108 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2015-01-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/63733
* interface.c (gfc_extend_expr): Look for type-bound operators before
non-typebound ones.
2015-01-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/58023

93
gcc/fortran/interface.c
View File

@ -3720,6 +3720,8 @@ gfc_extend_expr (gfc_expr *e)
gfc_user_op *uop;
gfc_intrinsic_op i;
const char *gname;
gfc_typebound_proc* tbo;
gfc_expr* tb_base;
sym = NULL;
@ -3736,6 +3738,48 @@ gfc_extend_expr (gfc_expr *e)
i = fold_unary_intrinsic (e->value.op.op);
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
i, e->value.op.uop->name, &gname);
else
switch (i)
{
#define CHECK_OS_COMPARISON(comp) \
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp, NULL, &gname); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp##_OS, NULL, &gname); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
CHECK_OS_COMPARISON(GT)
CHECK_OS_COMPARISON(GE)
CHECK_OS_COMPARISON(LT)
CHECK_OS_COMPARISON(LE)
#undef CHECK_OS_COMPARISON
default:
tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
/* If there is a matching typebound-operator, replace the expression with
a call to it and succeed. */
if (tbo)
{
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo, gname);
if (!gfc_resolve_expr (e))
return MATCH_ERROR;
else
return MATCH_YES;
}
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
@ -3786,58 +3830,9 @@ gfc_extend_expr (gfc_expr *e)
if (sym == NULL)
{
gfc_typebound_proc* tbo;
gfc_expr* tb_base;
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
i, e->value.op.uop->name, &gname);
else
switch (i)
{
#define CHECK_OS_COMPARISON(comp) \
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp, NULL, &gname); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp##_OS, NULL, &gname); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
CHECK_OS_COMPARISON(GT)
CHECK_OS_COMPARISON(GE)
CHECK_OS_COMPARISON(LT)
CHECK_OS_COMPARISON(LE)
#undef CHECK_OS_COMPARISON
default:
tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
/* If there is a matching typebound-operator, replace the expression with
a call to it and succeed. */
if (tbo)
{
bool result;
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
if (!result)
return MATCH_ERROR;
return MATCH_YES;
}
/* Don't use gfc_free_actual_arglist(). */
free (actual->next);
free (actual);
return MATCH_NO;
}

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2015-01-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/63733
* gfortran.dg/typebound_operator_20.f90: New.
2015-01-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/58023

53
gcc/testsuite/gfortran.dg/typebound_operator_20.f90 Normal file
View File

@ -0,0 +1,53 @@
! { dg-do run }
!
! PR 63733: [4.8/4.9/5 Regression] [OOP] wrong resolution for OPERATOR generics
!
! Original test case from Alberto F. Martín Huertas <amartin@cimne.upc.edu>
! Slightly modified by Salvatore Filippone <sfilippone@uniroma2.it>
! Further modified by Janus Weil <janus@gcc.gnu.org>
module overwrite
type parent
contains
procedure :: sum => sum_parent
generic :: operator(+) => sum
end type
type, extends(parent) :: child
contains
procedure :: sum => sum_child
end type
contains
integer function sum_parent(op1,op2)
implicit none
class(parent), intent(in) :: op1, op2
sum_parent = 0
end function
integer function sum_child(op1,op2)
implicit none
class(child) , intent(in) :: op1
class(parent), intent(in) :: op2
sum_child = 1
end function
end module
program drive
use overwrite
implicit none
type(parent) :: m1, m2
class(parent), pointer :: mres
type(child) :: h1, h2
class(parent), pointer :: hres
if (m1 + m2 /= 0) call abort()
if (h1 + m2 /= 1) call abort()
if (h1%sum(h2) /= 1) call abort()
end
! { dg-final { cleanup-modules "overwrite" } }