From: Janus Weil Date: Fri, 23 Aug 2013 16:43:15 +0000 (+0200) Subject: re PR fortran/57843 ([OOP] Type-bound assignment is resolved to non-polymorphic proce... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4f7395ffa13bb498c010aad0f08d137a7f766a1d;p=gcc.git re PR fortran/57843 ([OOP] Type-bound assignment is resolved to non-polymorphic procedure call) 2013-08-23 Janus Weil PR fortran/57843 * interface.c (gfc_extend_assign): Look for type-bound assignment procedures before non-typebound. 2013-08-23 Janus Weil PR fortran/57843 * gfortran.dg/typebound_assignment_7.f90: New. From-SVN: r201946 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 122f6c689c9..35f970ead81 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2013-08-23 Janus Weil + + PR fortran/57843 + * interface.c (gfc_extend_assign): Look for type-bound assignment + procedures before non-typebound. + 2013-08-23 Mikael Morin * trans-array.c (gfc_conv_section_startstride): Move &loop->pre access diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9055cf538f1..aa88b3c3fa6 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -3754,20 +3754,18 @@ gfc_extend_expr (gfc_expr *e) } -/* Tries to replace an assignment code node with a subroutine call to - the subroutine associated with the assignment operator. Return - true if the node was replaced. On false, no error is - generated. */ +/* Tries to replace an assignment code node with a subroutine call to the + subroutine associated with the assignment operator. Return true if the node + was replaced. On false, no error is generated. */ bool gfc_extend_assign (gfc_code *c, gfc_namespace *ns) { gfc_actual_arglist *actual; - gfc_expr *lhs, *rhs; - gfc_symbol *sym; - const char *gname; - - gname = NULL; + gfc_expr *lhs, *rhs, *tb_base; + gfc_symbol *sym = NULL; + const char *gname = NULL; + gfc_typebound_proc* tbo; lhs = c->expr1; rhs = c->expr2; @@ -3785,8 +3783,26 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) actual->next = gfc_get_actual_arglist (); actual->next->expr = rhs; - sym = NULL; + /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ + + /* See if we find a matching type-bound assignment. */ + tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, + NULL, &gname); + + if (tbo) + { + /* Success: Replace the expression with a type-bound call. */ + gcc_assert (tb_base); + c->expr1 = gfc_get_expr (); + build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); + c->expr1->value.compcall.assign = 1; + c->expr1->where = c->loc; + c->expr2 = NULL; + c->op = EXEC_COMPCALL; + return true; + } + /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ for (; ns; ns = ns->parent) { sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); @@ -3794,47 +3810,21 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns) break; } - /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ - - if (sym == NULL) + if (sym) { - gfc_typebound_proc* tbo; - gfc_expr* tb_base; - - /* See if we find a matching type-bound assignment. */ - tbo = matching_typebound_op (&tb_base, actual, - INTRINSIC_ASSIGN, NULL, &gname); - - /* If there is one, replace the expression with a call to it and - succeed. */ - if (tbo) - { - gcc_assert (tb_base); - c->expr1 = gfc_get_expr (); - build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); - c->expr1->value.compcall.assign = 1; - c->expr1->where = c->loc; - c->expr2 = NULL; - c->op = EXEC_COMPCALL; - - /* c is resolved from the caller, so no need to do it here. */ - - return true; - } - - free (actual->next); - free (actual); - return false; + /* Success: Replace the assignment with the call. */ + c->op = EXEC_ASSIGN_CALL; + c->symtree = gfc_find_sym_in_symtree (sym); + c->expr1 = NULL; + c->expr2 = NULL; + c->ext.actual = actual; + return true; } - /* Replace the assignment with the call. */ - c->op = EXEC_ASSIGN_CALL; - c->symtree = gfc_find_sym_in_symtree (sym); - c->expr1 = NULL; - c->expr2 = NULL; - c->ext.actual = actual; - - return true; + /* Failure: No assignment procedure found. */ + free (actual->next); + free (actual); + return false; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 47196da0508..5d9c3bb70c8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2013-08-23 Janus Weil + + PR fortran/57843 + * gfortran.dg/typebound_assignment_7.f90: New. + 2013-08-23 Jan Hubicka * g++.dg/ipa/devirt-13.C: New testcase. diff --git a/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90 b/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90 new file mode 100644 index 00000000000..2c5b837d670 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_assignment_7.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! +! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call +! +! Contributed by John + +module mod1 + implicit none + type :: itemType + contains + procedure :: the_assignment => assign_itemType + generic :: assignment(=) => the_assignment + end type +contains + subroutine assign_itemType(left, right) + class(itemType), intent(OUT) :: left + class(itemType), intent(IN) :: right + end subroutine +end module + +module mod2 + use mod1 + implicit none + type, extends(itemType) :: myItem + character(3) :: name = '' + contains + procedure :: the_assignment => assign_myItem + end type +contains + subroutine assign_myItem(left, right) + class(myItem), intent(OUT) :: left + class(itemType), intent(IN) :: right + select type (right) + type is (myItem) + left%name = right%name + end select + end subroutine +end module + + +program test_assign + + use mod2 + implicit none + + class(itemType), allocatable :: item1, item2 + + allocate (myItem :: item1) + select type (item1) + type is (myItem) + item1%name = 'abc' + end select + + allocate (myItem :: item2) + item2 = item1 + + select type (item2) + type is (myItem) + if (item2%name /= 'abc') call abort() + class default + call abort() + end select + +end + +! { dg-final { cleanup-modules "mod1 mod2" } }