From 8294f55513cd9f15b6ac729265c45a7a6837898f Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Sun, 20 Nov 2016 15:21:43 +0100 Subject: [PATCH] re PR fortran/78395 ([OOP] error on polymorphic assignment) gcc/testsuite/ChangeLog: 2016-11-20 Andre Vehreschild PR fortran/78395 * gfortran.dg/typebound_operator_21.f03: New test. gcc/fortran/ChangeLog: 2016-11-20 Andre Vehreschild PR fortran/78395 * resolve.c (resolve_typebound_function): Prevent stripping of refs, when the base-expression is a class' typed one. From-SVN: r242637 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/resolve.c | 2 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/typebound_operator_21.f03 | 78 +++++++++++++++++++ 4 files changed, 90 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_21.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 619da1baa20..c06bb162c07 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-11-20 Andre Vehreschild + + PR fortran/78395 + * resolve.c (resolve_typebound_function): Prevent stripping of refs, + when the base-expression is a class' typed one. + 2016-11-18 Richard Sandiford Alan Hayward David Sherwood diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 825bb12a517..589a673e52e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6140,7 +6140,7 @@ resolve_typebound_function (gfc_expr* e) gfc_free_ref_list (class_ref->next); class_ref->next = NULL; } - else if (e->ref && !class_ref) + else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) { gfc_free_ref_list (e->ref); e->ref = NULL; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e64536642dc..c20d91d85c8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-20 Andre Vehreschild + + PR fortran/78395 + * gfortran.dg/typebound_operator_21.f03: New test. + 2016-11-20 Marc Glisse * gcc.dg/tree-ssa/divide-5.c: New file. diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_21.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_21.f03 new file mode 100644 index 00000000000..bd99ffcee00 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_21.f03 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! Test that pr78395 is fixed. +! Contributed by Chris MacMackin and Janus Weil + +module types_mod + implicit none + + type, public :: t1 + integer :: a + contains + procedure :: get_t2 + end type + + type, public :: t2 + integer :: b + contains + procedure, pass(rhs) :: mul2 + procedure :: assign + generic :: operator(*) => mul2 + generic :: assignment(=) => assign + end type + +contains + + function get_t2(this) + class(t1), intent(in) :: this + class(t2), allocatable :: get_t2 + type(t2), allocatable :: local + allocate(local) + local%b = this%a + call move_alloc(local, get_t2) + end function + + function mul2(lhs, rhs) + class(t2), intent(in) :: rhs + integer, intent(in) :: lhs + class(t2), allocatable :: mul2 + type(t2), allocatable :: local + allocate(local) + local%b = rhs%b*lhs + call move_alloc(local, mul2) + end function + + subroutine assign(this, rhs) + class(t2), intent(out) :: this + class(t2), intent(in) :: rhs + select type(rhs) + type is(t2) + this%b = rhs%b + class default + error stop + end select + end subroutine + +end module + + +program minimal + use types_mod + implicit none + + class(t1), allocatable :: v4 + class(t2), allocatable :: v6 + + allocate(v4, source=t1(4)) + allocate(v6) + v6 = 3 * v4%get_t2() + + select type (v6) + type is (t2) + if (v6%b /= 12) error stop + class default + error stop + end select + deallocate(v4, v6) +end + -- 2.30.2