From da3723a8d5fd122e23d3664c37cb2f63b8b6ebcf Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 2 Oct 2017 18:17:39 +0000 Subject: [PATCH] re PR fortran/82312 ([OOP] Pointer assignment to component of class variable results wrong vptr for the variable.) 2017-10-02 Paul Thomas 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 PR fortran/82312 * gfortran.dg/typebound_proc_36.f90 : New test. From-SVN: r253362 --- gcc/fortran/ChangeLog | 11 +++ gcc/fortran/resolve.c | 5 +- gcc/fortran/trans-expr.c | 66 ++++++++++------ gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/typebound_proc_36.f90 | 77 +++++++++++++++++++ 5 files changed, 136 insertions(+), 28 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_36.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b5eea8770a4..0e7c7a8e787 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2017-10-02 Paul Thomas + + 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 PR fortran/61450 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a3a62deb6d1..698cf6de2fd 100644 --- 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 8c8569f1d86..d1b61b5228b 100644 --- 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 f679836903b..8c513943392 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-10-02 Paul Thomas + + PR fortran/82312 + * gfortran.dg/typebound_proc_36.f90 : New test. + 2017-10-02 Peter Bergner 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 index 00000000000..5c9193c1e70 --- /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 -- 2.30.2