2011-05-07 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* interface.c (compare_parameter): Skip diagnostic if
actual argument is not an array; rank mismatch is diagnosted later.
* trans-decl.c (gfc_get_symbol_decl, gfc_trans_deferred_vars): Handle
scalar coarrays.
* trans-types.c (gfc_get_array_type_bounds): Ditto.
2011-05-07 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.de/coarray_20.f90: New.
* gfortran.dg/coarray/image_index_2.f90: New.
@@ -1618,6 +1618,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
/* F2008, 12.5.2.8. */
if (formal->attr.dimension
&& (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+ && gfc_expr_attr (actual).dimension
&& !gfc_is_simply_contiguous (actual, true))
{
if (where)
@@ -1228,7 +1228,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
/* Use a copy of the descriptor for dummy arrays. */
- if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
+ if ((sym->attr.dimension || sym->attr.codimension)
+ && !TREE_USED (sym->backend_decl))
{
decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
/* Prevent the dummy from being detected as unused if it is copied. */
@@ -1316,7 +1317,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
DECL_IGNORED_P (decl) = 1;
}
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
{
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
@@ -3435,7 +3436,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
if (sym->assoc)
continue;
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
{
switch (sym->as->type)
{
@@ -1694,9 +1694,10 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
stride = gfc_index_one_node;
else
stride = NULL_TREE;
- for (n = 0; n < dimen; n++)
+ for (n = 0; n < dimen + codimen; n++)
{
- GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
+ if (n < dimen)
+ GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
if (lbound)
lower = lbound[n];
@@ -1711,6 +1712,9 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
lower = NULL_TREE;
}
+ if (codimen && n == dimen + codimen - 1)
+ break;
+
upper = ubound[n];
if (upper != NULL_TREE)
{
@@ -1720,6 +1724,9 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
upper = NULL_TREE;
}
+ if (n >= dimen)
+ continue;
+
if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Before a bogus error (argument not simply contiguous)
+! was printed instead of the rank mismatch
+!
+! PR fortran/18918
+!
+integer :: A[*]
+call bar(A) ! { dg-error "Rank mismatch in argument" }
+contains
+ subroutine bar(x)
+ integer :: x(1)[*]
+ end subroutine bar
+end
@@ -0,0 +1,76 @@
+! { dg-do run }
+!
+! Scalar coarray
+!
+! Run-time test for IMAGE_INDEX with cobounds only known at
+! the compile time, suitable for any number of NUM_IMAGES()
+! For compile-time cobounds, the -fcoarray=lib version still
+! needs to run-time evalulation if image_index returns > 1
+! as image_index is 0 if the index would exceed num_images().
+!
+! Please set num_images() to >= 13, if possible.
+!
+! PR fortran/18918
+!
+
+program test_image_index
+implicit none
+integer :: index1, index2, index3
+logical :: one
+
+integer, save :: d[-1:3, *]
+integer, save :: e[-1:-1, 3:*]
+
+one = num_images() == 1
+
+index1 = image_index(d, [-1, 1] )
+index2 = image_index(d, [0, 1] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+ call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+ call abort()
+
+index1 = image_index(e, [-1, 3] )
+index2 = image_index(e, [-1, 4] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+ call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+ call abort()
+
+call test(1, e, d, e)
+call test(2, e, d, e)
+
+contains
+subroutine test(n, a, b, c)
+ integer :: n
+ integer :: a[3*n:3*n, -4*n:-3*n, 88*n:*], b[-1*n:0*n,0*n:*], c[*]
+
+ index1 = image_index(a, [3*n, -4*n, 88*n] )
+ index2 = image_index(b, [-1, 0] )
+ index3 = image_index(c, [1] )
+
+ if (n == 1) then
+ if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+ else if (num_images() == 1) then
+ if (index1 /= 1 .or. index2 /= 0 .or. index3 /= 1) call abort()
+ else
+ if (index1 /= 1 .or. index2 /= 2 .or. index3 /= 1) call abort()
+ end if
+
+ index1 = image_index(a, [3*n, -3*n, 88*n] )
+ index2 = image_index(b, [0, 0] )
+ index3 = image_index(c, [2] )
+
+ if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+ call abort()
+ if (n == 1 .and. num_images() == 2) then
+ if (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2) &
+ call abort()
+ else if (n == 2 .and. num_images() == 2) then
+ if (index1 /= 0 .or. index2 /= 0 .or. index3 /= 2) &
+ call abort()
+ end if
+end subroutine test
+end program test_image_index
The interface.c patch is to avoid a strange error ("actual argument must be simply contiguous") which is a bit odd if the actual argument is a scalar. As the dummy was an array, a rank mismatch would have been the proper error. - The patch simply suppresses the error message such that the later error check becomes active. The rest of the patch: For scalar coarray dummy arguments, the cobounds were not properly saved - thus calling the one of the coindex intrinsics gave an ICE. Build and regtested on x86-64-linux. OK for the trunk? Tobias