Patch, fortran] PR fortran/100097 PR fortran/100098 - [Unlimited] polymorphic pointers and allocatables have incorrect rank

Patch, fortran] PR fortran/100097 PR fortran/100098 - [Unlimited] polymorphic pointers and allocatables have incorrect rank

[José Rui Faustino de Sousa]

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

Hi All!

Proposed patch to:

PR100097 - Unlimited polymorphic pointers and allocatables have 
incorrect rank
PR100098 - Polymorphic pointers and allocatables have incorrect rank

Patch tested only on x86_64-pc-linux-gnu.

Pointers, and allocatables, must carry TKR information even when 
undefined. The patch adds code to initialize, for both pointers and 
allocatables, the class descriptor element size, rank and type as soon 
as possible to do so.

Thank you very much.

Best regards,
José Rui

Fortran: Add missing TKR initialization to class variables [PR100097, 
PR100098]

gcc/fortran/ChangeLog:

	PR fortran/100097
	PR fortran/100098
	* trans-array.c (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.c (gfc_trans_deferred_vars): add calls to the new
	function for both pointers and allocatables.

gcc/testsuite/ChangeLog:

	PR fortran/100097
	* gfortran.dg/PR100097.f90: New test.

	PR fortran/100098
	* gfortran.dg/PR100098.f90: New test.


[-- Attachment #2: PR100098.patch --]
[-- Type: text/x-patch, Size: 5267 bytes --]

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index be5eb89350f..acd44a347e2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10808,6 +10808,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 e4d443d7118..d2768f1be61 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -67,6 +67,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.c b/gcc/fortran/trans-decl.c
index 34a0d49bae7..6a0d80bccb0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4929,7 +4929,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)
@@ -5013,6 +5013,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..926eb6cc779
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100097.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+!
+! 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)
+  stop
+
+contains
+
+  subroutine foo_p(that)
+    class(*), pointer, intent(out) :: that(..)
+
+    select rank(that)
+    rank(1)
+    rank default
+      stop 1
+    end select
+    return
+  end subroutine foo_p
+
+  subroutine foo_a(that)
+    class(*), allocatable, intent(out) :: that(..)
+
+    select rank(that)
+    rank(1)
+    rank default
+      stop 2
+    end select
+    return
+  end subroutine foo_a
+
+end program main_p
diff --git a/gcc/testsuite/gfortran.dg/PR100098.f90 b/gcc/testsuite/gfortran.dg/PR100098.f90
new file mode 100644
index 00000000000..96d1754cc80
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100098.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+! 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)
+  stop
+
+contains
+
+  subroutine foo_p(that)
+    class(foo_t), pointer, intent(out) :: that(..)
+
+    select rank(that)
+    rank(1)
+    rank default
+      stop 1
+    end select
+    return
+  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
+    return
+  end subroutine foo_a
+
+end program main_p