Hello All, As pointed out by Mikael in the PR, this bug was due to interface mapping not using a descriptor type for an assumed rank formal of a non-intrinsic function. The attached patch remedies this.
Bootstrap with FC43/x86_64. OK for mainline and backporting? Cheers Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a67248f7afa..d5254be007d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4906,13 +4906,15 @@ gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
array variable that can be used as the actual argument for dummy
- argument SYM. Add any initialization code to BLOCK. PACKED is as
- for gfc_get_nodesc_array_type and DATA points to the first element
- in the passed array. */
+ argument SYM, except in the case of assumed rank dummies of
+ non-intrinsic functions where the descriptor must be passed. Add any
+ initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
+ and DATA points to the first element in the passed array. */
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
- gfc_packed packed, tree data, tree len)
+ gfc_packed packed, tree data, tree len,
+ bool assumed_rank_formal)
{
tree type;
tree var;
@@ -4921,7 +4923,11 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
type = gfc_get_character_type_len (sym->ts.kind, len);
else
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
+
+ if (assumed_rank_formal)
+ type = TREE_TYPE (data);
+ else
+ type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.target && !sym->attr.pointer
&& !sym->attr.proc_pointer);
@@ -5094,15 +5100,27 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
{
+ bool assumed_rank_formal = false;
+
/* Get the actual argument's descriptor. */
desc = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Create the replacement variable. */
- tmp = gfc_conv_descriptor_data_get (desc);
+ if (sym->as && sym->as->type == AS_ASSUMED_RANK
+ && !(sym->ns && sym->ns->proc_name
+ && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
+ {
+ assumed_rank_formal = true;
+ tmp = desc;
+ }
+ else
+ tmp = gfc_conv_descriptor_data_get (desc);
+
value = gfc_get_interface_mapping_array (&se->pre, sym,
PACKED_NO, tmp,
- se->string_length);
+ se->string_length,
+ assumed_rank_formal);
/* Use DESC to work out the upper bounds, strides and offset. */
gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
@@ -5111,7 +5129,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
/* Otherwise we have a packed array. */
value = gfc_get_interface_mapping_array (&se->pre, sym,
PACKED_FULL, se->expr,
- se->string_length);
+ se->string_length,
+ false);
new_sym->backend_decl = value;
}
diff --git a/gcc/testsuite/gfortran.dg/pr102619.f90 b/gcc/testsuite/gfortran.dg/pr102619.f90
new file mode 100644
index 00000000000..ce4d0a0d7be
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102619.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Test the fix for PR102619.
+!
+! Contributed by Gerhard Steinmetz <[email protected]>
+!
+program p
+ implicit none
+ real :: w(2,3)
+ real, allocatable :: y(:)
+ y = h(w) ! Caused an ICE
+ if (size (y) /= product (shape (w))) stop 1
+ if (any (int (y) /= [1,2,3,4,5,6])) stop 2
+ deallocate (y)
+contains
+ function h(x) result (g)
+ real :: x(..)
+ real :: g(product(shape(x)))
+ integer :: i
+ if (any (shape (x) /= shape (w))) stop 3
+ g = [(real(i),i=1,size(g))]
+ end
+end
