From: José Rui Faustino de Sousa <jrfsousa@gmail.com>
Date: Fri, 16 Apr 2021 23:33:04 +0000 (+0000)
Subject: Fortran: Add missing TKR initialization [PR100094]
X-Git-Tag: basepoints/gcc-12~29
X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=c1c86ab96c20a3f52fb59e0532ae9c93665deb44;p=thirdparty%2Fgcc.git

Fortran: Add missing TKR initialization [PR100094]

gcc/fortran/ChangeLog:

	PR fortran/100094
	* trans-array.c (gfc_trans_deferred_array): Add code to initialize
	pointers and allocatables with correct TKR parameters.

gcc/testsuite/ChangeLog:

	PR fortran/100094
	* gfortran.dg/PR100094.f90: New test.
---

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ca90142530c2..e99980fd2233 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10874,6 +10874,20 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
 	}
     }
 
+  /* Set initial TKR for pointers and allocatables */
+  if (GFC_DESCRIPTOR_TYPE_P (type)
+      && (sym->attr.pointer || sym->attr.allocatable))
+    {
+      tree etype;
+
+      gcc_assert (sym->as && sym->as->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 (sym->as->rank, etype));
+      gfc_add_expr_to_block (&init, tmp);
+    }
   gfc_restore_backend_locus (&loc);
   gfc_init_block (&cleanup);
 
diff --git a/gcc/testsuite/gfortran.dg/PR100094.f90 b/gcc/testsuite/gfortran.dg/PR100094.f90
new file mode 100644
index 000000000000..f2f7f1631dcf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100094.f90
@@ -0,0 +1,37 @@
+! { dg-do run }
+!
+! Test the fix for PR100094
+!
+
+program foo_p
+
+  implicit none
+
+  integer, parameter :: n = 11
+  
+  integer, pointer :: pout(:)
+  integer,  target :: a(n)
+  integer          :: i
+  
+  a = [(i, i=1,n)]
+  call foo(pout)
+  if(.not.associated(pout)) stop 1
+  if(.not.associated(pout, a)) stop 2
+  if(any(pout/=a)) stop 3
+  stop
+
+contains
+
+  subroutine foo(that)
+    integer, pointer, intent(out) :: that(..)
+
+    select rank(that)
+    rank(1)
+      that => a
+    rank default
+      stop 4
+    end select
+    return
+  end subroutine foo
+
+end program foo_p