public inbox for gcc-cvs@sourceware.org help / color / mirror / Atom feed
From: Harald Anlauf <anlauf@gcc.gnu.org> To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-3440] Fortran: Add missing TKR initialization to class variables [PR100097, PR100098] Date: Fri, 21 Oct 2022 18:19:11 +0000 (GMT) [thread overview] Message-ID: <20221021181911.E3AFA3856DC0@sourceware.org> (raw) https://gcc.gnu.org/g:4cfdaeb2755121ac1069f09898def56469b0fb51 commit r13-3440-g4cfdaeb2755121ac1069f09898def56469b0fb51 Author: José Rui Faustino de Sousa <jrfsousa@gmail.com> 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" } }
reply other threads:[~2022-10-21 18:19 UTC|newest] Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions: You may reply publicly to this message via plain-text email using any one of the following methods: * Save the following mbox file, import it into your mail client, and reply-to-all from there: mbox Avoid top-posting and favor interleaved quoting: https://en.wikipedia.org/wiki/Posting_style#Interleaved_style * Reply using the --to, --cc, and --in-reply-to switches of git-send-email(1): git send-email \ --in-reply-to=20221021181911.E3AFA3856DC0@sourceware.org \ --to=anlauf@gcc.gnu.org \ --cc=gcc-cvs@gcc.gnu.org \ /path/to/YOUR_REPLY https://kernel.org/pub/software/scm/git/docs/git-send-email.html * If your mail client supports setting the In-Reply-To header via mailto: links, try the mailto: linkBe sure your reply has a Subject: header at the top and a blank line before the message body.
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).