From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 4EDB63858406; Sat, 29 Oct 2022 20:25:06 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 4EDB63858406 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1667075106; bh=I2z/xK6U36z3tBU8LN7O6Cnk+ecf2BJ++xUvLCjLVFk=; h=From:To:Subject:Date:From; b=rg0MNMKCP7XNX4vRpPEhl5JXMpw8Z2ewOznetZcMbP4A/6xeArGHFnI4ufC8I0q0R Qu4xEV7PIFkCl9lgkpfvY0JqDpvvUxEqtiJqHQp2O09wZ1JxRxAYqp188m1k7pABzj vnOoX67+gQj4Q8pl+84Wn8eTXllv41GmETj2WZwM= MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r11-10345] Fortran: Add missing TKR initialization to class variables [PR100097, PR100098] X-Act-Checkin: gcc X-Git-Author: =?utf-8?q?Jos=C3=A9_Rui_Faustino_de_Sousa?= X-Git-Refname: refs/heads/releases/gcc-11 X-Git-Oldrev: dd27a84503b724b5a0b4d2bf53f5bb79219e774d X-Git-Newrev: f6e4a3b40b69e4f682db2fe49139b17de1b2ef8c Message-Id: <20221029202506.4EDB63858406@sourceware.org> Date: Sat, 29 Oct 2022 20:25:06 +0000 (GMT) List-Id: https://gcc.gnu.org/g:f6e4a3b40b69e4f682db2fe49139b17de1b2ef8c commit r11-10345-gf6e4a3b40b69e4f682db2fe49139b17de1b2ef8c Author: José Rui Faustino de Sousa Date: Tue Oct 18 22:29:59 2022 +0200 Fortran: Add missing TKR initialization to class variables [PR100097, PR100098] gcc/fortran/ChangeLog: PR fortran/100097 PR fortran/100098 * trans-array.c (gfc_trans_class_array): New function to initialize class descriptor's TKR information. * trans-array.h (gfc_trans_class_array): Add function prototype. * trans-decl.c (gfc_trans_deferred_vars): Add calls to the new function for both pointers and allocatables. gcc/testsuite/ChangeLog: PR fortran/100097 PR fortran/100098 * gfortran.dg/PR100097.f90: New test. * gfortran.dg/PR100098.f90: New test. (cherry picked from commit 4cfdaeb2755121ac1069f09898def56469b0fb51) Diff: --- gcc/fortran/trans-array.c | 46 ++++++++++++++++++++++++++++++++++ gcc/fortran/trans-array.h | 2 ++ gcc/fortran/trans-decl.c | 6 ++++- gcc/testsuite/gfortran.dg/PR100097.f90 | 41 ++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/PR100098.f90 | 45 +++++++++++++++++++++++++++++++++ 5 files changed, 139 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ad6a30a47ca..abdecc7df7a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -10795,6 +10795,52 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, } +/* Initialize class descriptor's TKR infomation. */ + +void +gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block) +{ + tree type, etype; + tree tmp; + tree descriptor; + stmtblock_t init; + locus loc; + int rank; + + /* Make sure the frontend gets these right. */ + gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && (CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable)); + + gcc_assert (VAR_P (sym->backend_decl) + || TREE_CODE (sym->backend_decl) == PARM_DECL); + + if (sym->attr.dummy) + return; + + descriptor = gfc_class_data_get (sym->backend_decl); + type = TREE_TYPE (descriptor); + + if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type)) + return; + + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + gfc_init_block (&init); + + rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0); + gcc_assert (rank>=0); + tmp = gfc_conv_descriptor_dtype (descriptor); + etype = gfc_get_element_type (type); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp, + gfc_get_dtype_rank_type (rank, etype)); + gfc_add_expr_to_block (&init, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_restore_backend_locus (&loc); +} + + /* NULLIFY an allocatable/pointer array on function entry, free it on exit. Do likewise, recursively if necessary, with the allocatable components of derived types. This function is also called for assumed-rank arrays, which diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index def6f8a43a0..0ec77cf27e1 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -67,6 +67,8 @@ tree gfc_check_pdt_dummy (gfc_symbol *, tree, int, gfc_actual_arglist *); tree gfc_alloc_allocatable_for_assignment (gfc_loopinfo*, gfc_expr*, gfc_expr*); +/* Add initialization for class descriptors */ +void gfc_trans_class_array (gfc_symbol *, gfc_wrapped_block *); /* Add initialization for deferred arrays. */ void gfc_trans_deferred_array (gfc_symbol *, gfc_wrapped_block *); /* Generate an initializer for a static pointer or allocatable array. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 68fb19e6f2b..85382e6d6f7 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4923,7 +4923,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)) - continue; + gfc_trans_class_array (sym, block); else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable || (sym->attr.pointer && sym->attr.result) @@ -5007,6 +5007,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) tmp = NULL_TREE; } + /* Initialize descriptor's TKR information. */ + if (sym->ts.type == BT_CLASS) + gfc_trans_class_array (sym, block); + /* Deallocate when leaving the scope. Nullifying is not needed. */ if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer diff --git a/gcc/testsuite/gfortran.dg/PR100097.f90 b/gcc/testsuite/gfortran.dg/PR100097.f90 new file mode 100644 index 00000000000..f927d293e2c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100097.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR100097 +! + +program main_p + implicit none + + class(*), pointer :: bar_p(:) + class(*), allocatable :: bar_a(:) + + call foo_p(bar_p) + call foo_a(bar_a) + +contains + + subroutine foo_p(that) + class(*), pointer, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 1 + end select + end subroutine foo_p + + subroutine foo_a(that) + class(*), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 2 + end select + end subroutine foo_a + +end program main_p + +! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } } +! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } } diff --git a/gcc/testsuite/gfortran.dg/PR100098.f90 b/gcc/testsuite/gfortran.dg/PR100098.f90 new file mode 100644 index 00000000000..26ac0c88425 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR100098.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR100098 +! + +program main_p + implicit none + + type :: foo_t + integer :: i + end type foo_t + + class(foo_t), pointer :: bar_p(:) + class(foo_t), allocatable :: bar_a(:) + + call foo_p(bar_p) + call foo_a(bar_a) + +contains + + subroutine foo_p(that) + class(foo_t), pointer, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 1 + end select + end subroutine foo_p + + subroutine foo_a(that) + class(foo_t), allocatable, intent(out) :: that(..) + + select rank(that) + rank(1) + rank default + stop 2 + end select + end subroutine foo_a + +end program main_p + +! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } } +! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } }