From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Sun, 20 Nov 2016 14:21:43 +0000 (+0100)
Subject: re PR fortran/78395 ([OOP] error on polymorphic assignment)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8294f55513cd9f15b6ac729265c45a7a6837898f;p=gcc.git

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 619da1baa20..c06bb162c07 100644
--- 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 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  <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
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
+