@@ -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
@@ -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. */
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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