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

2017-10-21  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-21  Paul Thomas  <pault@gcc.gnu.org>

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

From-SVN: r253976
This commit is contained in:
Paul Thomas 2017-10-21 17:09:43 +00:00
parent 1b962a501d
commit 735b7d675a
5 changed files with 138 additions and 28 deletions

View File

@ -1,3 +1,15 @@
2017-10-21 Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
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-20 Thomas Koenig <tkoenig@gcc.gnu.org>
Backport from trunk

View File

@ -11017,11 +11017,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

View File

@ -8205,6 +8205,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)
{
@ -8223,6 +8256,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
tree desc;
tree tmp;
tree decl;
tree expr1_vptr = NULL_TREE;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
@ -8256,7 +8290,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)
{
@ -8268,12 +8305,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);
@ -8319,7 +8356,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;
@ -8354,26 +8390,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];

View File

@ -1,3 +1,9 @@
2017-10-21 Paul Thomas <pault@gcc.gnu.org>
Backport from trunk
PR fortran/82312
* gfortran.dg/typebound_proc_36.f90 : New test.
2017-10-20 Thomas Koenig <tkoenig@gcc.gnu.org>
Backport from trunk

View File

@ -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