Skip to content

R
riscv-gcc-1
Commit 6a943ee7 by Paul Thomas
Options

re PR fortran/43291 ([OOP] Type mismatch in argument; passed CLASS(t1) to CLASS(t2)) 

2010-03-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* resolve.c (resolve_compcall): Add new boolean dummy argument
	'class_members'. Only resolve expression at end if false.
	Remove redundant, static variable 'class_object'.
	(check_class_members): Add extra argument to call of
	resolve_compcall.
	(resolve_typebound_function): Renamed resolve_class_compcall.
	Do all the detection of class references here. Correct calls to
	resolve_compcall for extra argument.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-03-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_7.f03: New test.

From-SVN: r157411
parent 9c8cab44
Showing with 117 additions and 26 deletions
gcc/fortran/ChangeLog
2010-03-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43291
PR fortran/43326
* resolve.c (resolve_compcall): Add new boolean dummy argument
'class_members'. Only resolve expression at end if false.
Remove redundant, static variable 'class_object'.
(check_class_members): Add extra argument to call of
resolve_compcall.
(resolve_typebound_function): Renamed resolve_class_compcall.
Do all the detection of class references here. Correct calls to
resolve_compcall for extra argument.
(resolve_typebound_subroutine): resolve_class_typebound_call
renamed. Otherwise same as resolve_typebound_function.
(gfc_resolve_expr): Call resolve_typebound_function.
(resolve_code): Call resolve_typebound_subroutine.
2010-03-10 Tobias Burnus <burnus@net-b.de
PR fortran/43303
......
gcc/fortran/resolve.c
......@@ -5082,7 +5082,7 @@ resolve_typebound_call (gfc_code* c)
resolving subroutine class methods, since we do not have to add a
gfc_code each time. */
static gfc_try
resolve_compcall (gfc_expr* e, bool fcn)
resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
......@@ -5132,10 +5132,10 @@ resolve_compcall (gfc_expr* e, bool fcn)
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
/* Resolution is not necessary if this is a class subroutine; this
function only has to identify the specific proc. Resolution of
the call will be done next in resolve_typebound_call. */
return fcn ? gfc_resolve_expr (e) : SUCCESS;
/* Resolution is not necessary when constructing component calls
for class members, since this must only be done for the
declared type, which is done afterwards. */
return !class_members ? gfc_resolve_expr (e) : SUCCESS;
}
......@@ -5147,7 +5147,6 @@ static gfc_expr *list_e;
static void check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
static gfc_symbol *class_object;
static void
......@@ -5202,7 +5201,7 @@ check_class_members (gfc_symbol *derived)
/* Do the renaming, PASSing, generic => specific and other
good things for each class member. */
class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
? class_try : FAILURE;
/* Now transfer the found symbol to the esym list. */
......@@ -5337,9 +5336,13 @@ resolve_arg_exprs (gfc_actual_arglist *arg)
}
/* Resolve a CLASS typebound function, or 'method'. */
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly.
Then treat the CLASS references by resolving for each of the class
members in turn. */
static gfc_try
resolve_class_compcall (gfc_expr* e)
resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
......@@ -5347,16 +5350,18 @@ resolve_class_compcall (gfc_expr* e)
gfc_symtree *st;
st = e->symtree;
class_object = st->n.sym;
if (st == NULL)
return resolve_compcall (e, true, false);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
return resolve_compcall (e, true);
return resolve_compcall (e, true, false);
}
/* Resolve the argument expressions, */
......@@ -5371,7 +5376,7 @@ resolve_class_compcall (gfc_expr* e)
list_e = gfc_copy_expr (e);
check_class_members (derived);
class_try = (resolve_compcall (e, true) == SUCCESS)
class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
/* Transfer the class list to the original expression. Note that
......@@ -5392,9 +5397,13 @@ resolve_class_compcall (gfc_expr* e)
return class_try;
}
/* Resolve a CLASS typebound subroutine, or 'method'. */
/* Resolve a typebound subroutine, or 'method'. First separate all
the non-CLASS references by calling resolve_typebound_call directly.
Then treat the CLASS references by resolving for each of the class
members in turn. */
static gfc_try
resolve_class_typebound_call (gfc_code *code)
resolve_typebound_subroutine (gfc_code *code)
{
gfc_symbol *derived, *declared;
gfc_ref *new_ref;
......@@ -5402,13 +5411,15 @@ resolve_class_typebound_call (gfc_code *code)
gfc_symtree *st;
st = code->expr1->symtree;
class_object = st->n.sym;
if (st == NULL)
return resolve_typebound_call (code);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
return resolve_typebound_call (code);
......@@ -5584,10 +5595,7 @@ gfc_resolve_expr (gfc_expr *e)
break;
case EXPR_COMPCALL:
if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
t = resolve_class_compcall (e);
else
t = resolve_compcall (e, true);
t = resolve_typebound_function (e);
break;
case EXPR_SUBSTRING:
......@@ -8150,11 +8158,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_COMPCALL:
compcall:
if (code->expr1->symtree
&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
resolve_class_typebound_call (code);
else
resolve_typebound_call (code);
resolve_typebound_subroutine (code);
break;
case EXEC_CALL_PPC:
......
gcc/testsuite/ChangeLog
2010-03-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43291
PR fortran/43326
* gfortran.dg/dynamic_dispatch_7.f03: New test.
2010-03-12 Kai Tietz <kai.tietz@onevision.com>
* gfortran.dg/default_format_denormal_1.f90: Don't assume
......
gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 0 → 100644
! { dg-do run }
! Test the fix for PR43291, which was a regression that caused
! incorrect type mismatch errors at line 46. In the course of
! fixing the PR, it was noted that the dynamic dispatch of the
! final typebound call was not occurring - hence the dg-do run.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
module m1
type :: t1
contains
procedure :: sizeof
end type
contains
integer function sizeof(a)
class(t1) :: a
sizeof = 1
end function sizeof
end module
module m2
use m1
type, extends(t1) :: t2
contains
procedure :: sizeof => sizeof2
end type
contains
integer function sizeof2(a)
class(t2) :: a
sizeof2 = 2
end function
end module
module m3
use m2
type :: t3
class(t1), pointer :: a
contains
procedure :: sizeof => sizeof3
end type
contains
integer function sizeof3(a)
class(t3) :: a
sizeof3 = a%a%sizeof()
end function
end module
use m1
use m2
use m3
type(t1), target :: x
type(t2), target :: y
type(t3) :: z
z%a => x
if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
z%a => y
if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
end
! { dg-final { cleanup-modules "m1 m2 m3" } }
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