re PR fortran/82312 ([OOP] Pointer assignment to component of class variable results wrong vptr for the variable.)

2017-10-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82312
	* resolve.c (gfc_resolve_code): Simplify condition for class
	pointer assignments becoming regular assignments by asserting
	that only class valued targets are permitted.
	* trans-expr.c (trans_class_pointer_fcn): New function using a
	block of code from gfc_trans_pointer_assignment.
	(gfc_trans_pointer_assignment): Call the new function. Tidy up
	a minor whitespace issue.

2017-10-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82312
	* gfortran.dg/typebound_proc_36.f90 : New test.

From-SVN: r253362

5 files changed, 136 insertions, 28 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b5eea87..0e7c7a8 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2017-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82312
+	* resolve.c (gfc_resolve_code): Simplify condition for class
+	pointer assignments becoming regular assignments by asserting
+	that only class valued targets are permitted.
+	* trans-expr.c (trans_class_pointer_fcn): New function using a
+	block of code from gfc_trans_pointer_assignment.
+	(gfc_trans_pointer_assignment): Call the new function. Tidy up
+	a minor whitespace issue.
+
 2017-10-01  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
 	PR fortran/61450
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a3a62de..698cf6d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11119,11 +11119,8 @@ start:
 
 	    /* Assigning a class object always is a regular assign.  */
 	    if (code->expr2->ts.type == BT_CLASS
+		&& code->expr1->ts.type == BT_CLASS
 		&& !CLASS_DATA (code->expr2)->attr.dimension
-		&& !(UNLIMITED_POLY (code->expr2)
-		     && code->expr1->ts.type == BT_DERIVED
-		     && (code->expr1->ts.u.derived->attr.sequence
-			 || code->expr1->ts.u.derived->attr.is_bind_c))
 		&& !(gfc_expr_attr (code->expr1).proc_pointer
 		     && code->expr2->expr_type == EXPR_VARIABLE
 		     && code->expr2->symtree->n.sym->attr.flavor
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8c8569f..d1b61b5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -8207,6 +8207,39 @@ pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
 }
 
 
+/* Do everything that is needed for a CLASS function expr2.  */
+
+static tree
+trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
+			 gfc_expr *expr1, gfc_expr *expr2)
+{
+  tree expr1_vptr = NULL_TREE;
+  tree tmp;
+
+  gfc_conv_function_expr (rse, expr2);
+  rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
+
+  if (expr1->ts.type != BT_CLASS)
+      rse->expr = gfc_class_data_get (rse->expr);
+  else
+    {
+      expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
+						    expr2, rse,
+						    NULL, NULL);
+      gfc_add_block_to_block (block, &rse->pre);
+      tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
+      gfc_add_modify (&lse->pre, tmp, rse->expr);
+
+      gfc_add_modify (&lse->pre, expr1_vptr,
+		      fold_convert (TREE_TYPE (expr1_vptr),
+		      gfc_class_vptr_get (tmp)));
+      rse->expr = gfc_class_data_get (tmp);
+    }
+
+  return expr1_vptr;
+}
+
+
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
@@ -8224,6 +8257,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   stmtblock_t block;
   tree desc;
   tree tmp;
+  tree expr1_vptr = NULL_TREE;
   bool scalar, non_proc_pointer_assign;
   gfc_ss *ss;
 
@@ -8257,7 +8291,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_conv_expr (&lse, expr1);
       gfc_init_se (&rse, NULL);
       rse.want_pointer = 1;
-      gfc_conv_expr (&rse, expr2);
+      if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
+	trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
+      else
+	gfc_conv_expr (&rse, expr2);
 
       if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
 	{
@@ -8269,12 +8306,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       if (expr1->symtree->n.sym->attr.proc_pointer
 	  && expr1->symtree->n.sym->attr.dummy)
 	lse.expr = build_fold_indirect_ref_loc (input_location,
-					    lse.expr);
+						lse.expr);
 
       if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
 	  && expr2->symtree->n.sym->attr.dummy)
 	rse.expr = build_fold_indirect_ref_loc (input_location,
-					    rse.expr);
+						rse.expr);
 
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
@@ -8320,7 +8357,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     {
       gfc_ref* remap;
       bool rank_remap;
-      tree expr1_vptr = NULL_TREE;
       tree strlen_lhs;
       tree strlen_rhs = NULL_TREE;
 
@@ -8355,26 +8391,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  rse.byref_noassign = 1;
 
 	  if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
-	    {
-	      gfc_conv_function_expr (&rse, expr2);
-
-	      if (expr1->ts.type != BT_CLASS)
-		rse.expr = gfc_class_data_get (rse.expr);
-	      else
-		{
-		  expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
-								expr2, &rse,
-								NULL, NULL);
-		  gfc_add_block_to_block (&block, &rse.pre);
-		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
-		  gfc_add_modify (&lse.pre, tmp, rse.expr);
-
-		  gfc_add_modify (&lse.pre, expr1_vptr,
-				  fold_convert (TREE_TYPE (expr1_vptr),
-						gfc_class_vptr_get (tmp)));
-		  rse.expr = gfc_class_data_get (tmp);
-		}
-	    }
+	    expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
+						  expr1, expr2);
 	  else if (expr2->expr_type == EXPR_FUNCTION)
 	    {
 	      tree bound[GFC_MAX_DIMENSIONS];
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f679836..8c51394 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-10-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82312
+	* gfortran.dg/typebound_proc_36.f90 : New test.
+
 2017-10-02  Peter Bergner  <bergner@vnet.ibm.com>
 
 	PR target/80210
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_36.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_36.f90
new file mode 100644
index 0000000..5c9193c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_proc_36.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! Test the fix for PR82312.f90
+!
+! Posted on Stack Overflow:
+! https://stackoverflow.com/questions/46369744
+! /gfortran-associates-wrong-type-bound-procedure/46388339#46388339
+!
+module minimalisticcase
+    implicit none
+
+    type, public :: DataStructure
+        integer :: i
+    contains
+        procedure, pass :: init => init_data_structure
+        procedure, pass :: a => beginning_of_alphabet
+    end type
+
+    type, public :: DataLogger
+        type(DataStructure), pointer :: data_structure
+        contains
+                procedure, pass :: init => init_data_logger
+                procedure, pass :: do_something => do_something
+    end type
+
+    integer :: ctr = 0
+
+contains
+    subroutine init_data_structure(self)
+        implicit none
+        class(DataStructure), intent(inout) :: self
+        write(*,*) 'init_data_structure'
+        ctr = ctr + 1
+    end subroutine
+
+    subroutine beginning_of_alphabet(self)
+        implicit none
+        class(DataStructure), intent(inout) :: self
+
+        write(*,*) 'beginning_of_alphabet'
+        ctr = ctr + 10
+    end subroutine
+
+    subroutine init_data_logger(self, data_structure)
+        implicit none
+        class(DataLogger), intent(inout) :: self
+        class(DataStructure), target :: data_structure
+        write(*,*) 'init_data_logger'
+        ctr = ctr + 100
+
+        self%data_structure => data_structure ! Invalid change of 'self' vptr
+        call self%do_something()
+    end subroutine
+
+    subroutine do_something(self)
+        implicit none
+        class(DataLogger), intent(inout) :: self
+
+        write(*,*) 'do_something'
+        ctr = ctr + 1000
+
+    end subroutine
+end module
+
+program main
+    use minimalisticcase
+    implicit none
+
+    type(DataStructure) :: data_structure
+    type(DataLogger) :: data_logger
+
+    call data_structure%init()
+    call data_structure%a()
+    call data_logger%init(data_structure)
+
+    if (ctr .ne. 1111) call abort
+end program