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
parent
1b962a501d
commit
735b7d675a
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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];
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue