[gcc r11-8228] Fortran: Add missing TKR initialization [PR100094]

[gcc r11-8228] Fortran: Add missing TKR initialization [PR100094]

[José Rui Faustino de Sousa]

https://gcc.gnu.org/g:c1c86ab96c20a3f52fb59e0532ae9c93665deb44

commit r11-8228-gc1c86ab96c20a3f52fb59e0532ae9c93665deb44
Author: José Rui Faustino de Sousa <jrfsousa@gmail.com>
Date:   Fri Apr 16 23:33:04 2021 +0000

    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:
---
 gcc/fortran/trans-array.c              | 14 +++++++++++++
 gcc/testsuite/gfortran.dg/PR100094.f90 | 37 ++++++++++++++++++++++++++++++++++
 2 files changed, 51 insertions(+)

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index ca90142530c..e99980fd223 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 00000000000..f2f7f1631dc
--- /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