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