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.
Version 2 no longer re-initializes explicit initialized variables, which
are taken care of elsewhere.
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.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6bcd2b..feec734 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10786,6 +10786,57 @@ 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);
+
+ /* Explicit initialization is done elsewhere. */
+ if (sym->attr.save || TREE_STATIC (descriptor))
+ return;
+
+ 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 e4d443d..d2768f1 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 479ba6f..659e973 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4943,7 +4943,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)
@@ -5027,6 +5027,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 0000000..926eb6c
--- /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 0000000..96d1754
--- /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
