Hi Mikael,
Am 21.10.22 um 13:13 schrieb Mikael Morin:
Le 18/10/2022 à 22:48, Harald Anlauf via Fortran a écrit :
I intended to add the updated patch but forgot, so here it is...
Am 18.10.22 um 22:41 schrieb Harald Anlauf via Fortran:
Dear all,
Jose posted a patch here that was never reviewed:
https://gcc.gnu.org/pipermail/fortran/2021-April/055933.html
I could not find any issues with his patch, it works as advertised
and fixes the reported problem.
As his testcases did not reliably fail without the patch but rather
randomly due to the uninitialized descriptor, I added a check of
the tree-dumps to verify that the TKR initializer is generated.
Does anybody else have any comments?
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Looks good but please check the initialization of rank instead of
elem_len in the dump patterns (elem_len actually doesn't matter).
OK with that change.
You're right, this is what I should have done in the first place.
Pushed: https://gcc.gnu.org/g:4cfdaeb2755121ac1069f09898def56469b0fb51
See also attached.
Thanks.
Thanks,
Harald
From 4cfdaeb2755121ac1069f09898def56469b0fb51 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jos=C3=A9=20Rui=20Faustino=20de=20Sousa?=
<jrfso...@gmail.com>
Date: Tue, 18 Oct 2022 22:29:59 +0200
Subject: [PATCH] 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.
---
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(-)
create mode 100644 gcc/testsuite/gfortran.dg/PR100097.f90
create mode 100644 gcc/testsuite/gfortran.dg/PR100098.f90
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" } }
--
2.35.3
