re PR fortran/78395 ([OOP] error on polymorphic assignment)

gcc/testsuite/ChangeLog:

2016-11-20  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78395
	* gfortran.dg/typebound_operator_21.f03: New test.

gcc/fortran/ChangeLog:

2016-11-20  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78395
	* resolve.c (resolve_typebound_function): Prevent stripping of refs,
	when the base-expression is a class' typed one.

From-SVN: r242637

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 619da1baa2079826be459122bbbf7de5a7103cf0..c06bb162c077c726f0129e319db4df0bc1e881ba 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2016-11-20  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       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  <richard.sandiford@arm.com>
            Alan Hayward  <alan.hayward@arm.com>
            David Sherwood  <david.sherwood@arm.com>

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 825bb12a517bdb2639d3660e4d7afe1b55882bb7..589a673e52ecd134acf4891a48d7cf4c79e42365 100644 (file)
--- 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 e64536642dc69cf24894b888883125cd7d16c367..c20d91d85c8481ba8887d9a0ba8533cca37df19f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-11-20  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/78395
+       * gfortran.dg/typebound_operator_21.f03: New test.
+
 2016-11-20  Marc Glisse  <marc.glisse@inria.fr>
 
        * 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 (file)
index 0000000..bd99ffc
--- /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
+