re PR fortran/82312 ([OOP] Pointer assignment to component of class variable results...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b5eea8770a4875cfb014f7f7676bc7b1b26e6b53..0e7c7a8e787cb3eafc46b2209d86be59767eb6d9 100644 (file)
--- 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 a3a62deb6d125047818cd620bfe19d3c53c18fe1..698cf6de2fdc4a8392fc73ddde80b60126b80658 100644 (file)
--- 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 8c8569f1d86497414d55e597600d34b9f207f3b4..d1b61b5228bb26e1884f12d0747feee96d995104 100644 (file)
--- 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 f679836903b66bfd9a7543d18ad7402fc5767ada..8c5139433922853a037e8ff9d806167ae89713ee 100644 (file)
--- 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 (file)
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