[PATCH, Fortran, pr78395, v1] [OOP] error on polymorphic assignment

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

attached patch fixes the issue which was given by nesting calls to typebound
procedures. The expression of the inner typebound procedure call was resolved
correctly, but in the case of it's having a class type the ref-list was
discarded. Leaving the list of references untouched, resolves the wrong
error-message and generates correct code.

When checking the shortened example in comment #3 one gets a segfault, because
v6 is not allocated explicitly. The initial example made sure, that v6 was
allocated. Reading through the standard, I did not find, whether the
auto-allocation is applicable here. I therefore have extended the testcase by
an allocate(v6). Dominique pointed out, that there are already some prs for
adding an on-demand -fcheck=something runtime check for not allocated objects.
But that does not solve the question, whether v6 should be auto-allocated
when assigned by a typebound-procedure (ifort and cray need v6 allocated do,
i.e., they don't auto-allocate). Btw, when using the in gcc-7 available
polymorphic assign, then v6 is actually auto-allocated and the program runs
fine. So what are your opinions on the auto-allocation issue?

This patch fixes the wrong error messages in both gcc-7 and gcc-6.
Bootstraped and regtested on x86_64-linux/F23 for gcc-7 and -6. Ok for trunk
and gcc-6?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr78395_1.clog
Description: Text document

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 825bb12..589a673 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/gfortran.dg/typebound_operator_21.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_21.f03
new file mode 100644
index 0000000..ea374a1
--- /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 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
+