From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id E3AFA3856DC0; Fri, 21 Oct 2022 18:19:11 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E3AFA3856DC0 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1666376351; bh=MbbptA7Zr9qNnzqF+3ZpCuBKmuJZhvg1xujwjnNVsuo=; h=From:To:Subject:Date:From; b=v6UOPsXdYV5RkgIoyxbccBbrkViga6RqRFW9rPh1kZjouF1pnMDb4ieSeskQ0WQTG 6lGyvhIw0mSFqDw5mL5CVDkC9yCc5ieykmILl9v9TQdxoq7s/Qxb9Iqm3/Yxuho1HM KgO58P10y+L2gpxUegNSoZAxobcPNBR+FdyGif2A= 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 r13-3440] 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/master X-Git-Oldrev: 5792208f5124f687376f25798668d105d7ddb270 X-Git-Newrev: 4cfdaeb2755121ac1069f09898def56469b0fb51 Message-Id: <20221021181911.E3AFA3856DC0@sourceware.org> Date: Fri, 21 Oct 2022 18:19:11 +0000 (GMT) List-Id: https://gcc.gnu.org/g:4cfdaeb2755121ac1069f09898def56469b0fb51 commit r13-3440-g4cfdaeb2755121ac1069f09898def56469b0fb51 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.cc (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.cc (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. Diff: --- gcc/fortran/trans-array.cc | 46 ++++++++++++++++++++++++++++++++++ gcc/fortran/trans-array.h | 2 ++ gcc/fortran/trans-decl.cc | 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.cc b/gcc/fortran/trans-array.cc index 795ce14af08..514cb057afb 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11125,6 +11125,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 04fee617590..cd2b3d9f2f0 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -69,6 +69,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.cc b/gcc/fortran/trans-decl.cc index 4b570c3551a..63515b9072a 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4835,7 +4835,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) @@ -4919,6 +4919,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" } }