* [Patch, fortran] PR 82312 - [7/8 Regression] Pointer assignment to component of class variable results wrong vptr for the variable
@ 2017-09-30 8:24 Paul Richard Thomas
2017-10-01 13:43 ` Thomas Koenig
0 siblings, 1 reply; 3+ messages in thread
From: Paul Richard Thomas @ 2017-09-30 8:24 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1175 bytes --]
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 <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-09-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/82312
* gfortran.dg/typebound_proc_36.f90 : New test.
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 8279 bytes --]
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
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [Patch, fortran] PR 82312 - [7/8 Regression] Pointer assignment to component of class variable results wrong vptr for the variable
2017-09-30 8:24 [Patch, fortran] PR 82312 - [7/8 Regression] Pointer assignment to component of class variable results wrong vptr for the variable Paul Richard Thomas
@ 2017-10-01 13:43 ` Thomas Koenig
2017-10-02 18:20 ` Paul Richard Thomas
0 siblings, 1 reply; 3+ messages in thread
From: Thomas Koenig @ 2017-10-01 13:43 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Hi Paul,
> Bootstraps and regtests on FC23/x86_64 - OK for trunk and 7 branch?
OK for both. Thanks for the patch!
Regards
Thomas
^ permalink raw reply [flat|nested] 3+ messages in thread
* Re: [Patch, fortran] PR 82312 - [7/8 Regression] Pointer assignment to component of class variable results wrong vptr for the variable
2017-10-01 13:43 ` Thomas Koenig
@ 2017-10-02 18:20 ` Paul Richard Thomas
0 siblings, 0 replies; 3+ messages in thread
From: Paul Richard Thomas @ 2017-10-02 18:20 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches
Committed as revision 253362.
Thanks for taking a look at it. I will wait a week or so before
committing to 7-branch.
Paul
On 1 October 2017 at 14:43, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Paul,
>
>> Bootstraps and regtests on FC23/x86_64 - OK for trunk and 7 branch?
>
>
> OK for both. Thanks for the patch!
>
> Regards
>
> Thomas
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2017-10-02 18:20 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-09-30 8:24 [Patch, fortran] PR 82312 - [7/8 Regression] Pointer assignment to component of class variable results wrong vptr for the variable Paul Richard Thomas
2017-10-01 13:43 ` Thomas Koenig
2017-10-02 18:20 ` Paul Richard Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).