Greetings to all,
This patch fixes a bug where the pointer assignment to the derived
component of a class entity was resulting in the base entity's vptr
being set to the vtable of the target. This resulted in the wrong
typebound procedure being called.
The patch corrects the logic in resolve code that determines when
regular assignment is used for class pointer assignment and breaks out
some codeto handle function targets from trans_pointer_assignment so
that function targets are correctly handled.
Bootstraps and regtests on FC23/x86_64 - OK for trunk and 7 branch?
Cheers
Paul
2017-09-30 Paul Thomas <pa...@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-09-30 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/82312
* gfortran.dg/typebound_proc_36.f90 : New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 253268)
--- gcc/fortran/resolve.c (working copy)
*************** start:
*** 11119,11129 ****
/* Assigning a class object always is a regular assign. */
if (code->expr2->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
--- 11119,11126 ----
/* 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
&& !(gfc_expr_attr (code->expr1).proc_pointer
&& code->expr2->expr_type == EXPR_VARIABLE
&& code->expr2->symtree->n.sym->attr.flavor
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 253268)
--- gcc/fortran/trans-expr.c (working copy)
*************** pointer_assignment_is_proc_pointer (gfc_
*** 8207,8212 ****
--- 8207,8245 ----
}
+ /* 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)
{
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8224,8229 ****
--- 8257,8263 ----
stmtblock_t block;
tree desc;
tree tmp;
+ tree expr1_vptr = NULL_TREE;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8257,8263 ****
gfc_conv_expr (&lse, expr1);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
! gfc_conv_expr (&rse, expr2);
if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
{
--- 8291,8300 ----
gfc_conv_expr (&lse, expr1);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
! 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)
{
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8269,8280 ****
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);
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);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
--- 8306,8317 ----
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);
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);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8320,8326 ****
{
gfc_ref* remap;
bool rank_remap;
- tree expr1_vptr = NULL_TREE;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
--- 8357,8362 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8355,8380 ****
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);
! }
! }
else if (expr2->expr_type == EXPR_FUNCTION)
{
tree bound[GFC_MAX_DIMENSIONS];
--- 8391,8398 ----
rse.byref_noassign = 1;
if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
! expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
! expr1, expr2);
else if (expr2->expr_type == EXPR_FUNCTION)
{
tree bound[GFC_MAX_DIMENSIONS];
Index: gcc/testsuite/gfortran.dg/typebound_proc_36.f90
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_proc_36.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/typebound_proc_36.f90 (working copy)
***************
*** 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
