Re: Proxy ping [PATCH] Fortran: Add missing TKR initialization to class variables [PR100097, PR100098]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 715 bytes --]

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?
>
> Thanks,
> Harald
>
>
>

[-- Attachment #2: pr100098.diff --]
[-- Type: text/x-patch, Size: 6914 bytes --]

From 8d364acf33f27262ef5929a3c8d504ed6df0f943 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jos=C3=A9=20Rui=20Faustino=20de=20Sousa?=
 <jrfsousa@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..2a077d0e473
--- /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 = \\{.elem_len=.*\\}" "original" } }
+! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.elem_len=.*\\}" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/PR100098.f90 b/gcc/testsuite/gfortran.dg/PR100098.f90
new file mode 100644
index 00000000000..55b1958aa4a
--- /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 = \\{.elem_len=.*\\}" "original" } }
+! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.elem_len=.*\\}" "original" } }
-- 
2.35.3