From: Paul Thomas Date: Fri, 12 Mar 2010 22:00:52 +0000 (+0000) Subject: re PR fortran/43291 ([OOP] Type mismatch in argument; passed CLASS(t1) to CLASS(t2)) X-Git-Tag: releases/gcc-4.5.0~403 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=6a943ee764c9719ba67245e3db7d9a84043da30a;p=thirdparty%2Fgcc.git re PR fortran/43291 ([OOP] Type mismatch in argument; passed CLASS(t1) to CLASS(t2)) 2010-03-12 Paul Thomas 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 PR fortran/43291 PR fortran/43326 * gfortran.dg/dynamic_dispatch_7.f03: New test. From-SVN: r157411 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f9bde0068f8c..9fd831dbd7c4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2010-03-12 Paul Thomas + + 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 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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ad502352d58d..5db28bd9bcf7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2010-03-12 Paul Thomas + + PR fortran/43291 + PR fortran/43326 + * gfortran.dg/dynamic_dispatch_7.f03: New test. + 2010-03-12 Kai Tietz * gfortran.dg/default_format_denormal_1.f90: Don't assume diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 new file mode 100644 index 000000000000..a84d9f9c483a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 @@ -0,0 +1,64 @@ +! { 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 +! +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" } } +