Patchwork [Fortran] Fixes for scalar coarrays

login
register
mail settings
Submitter Tobias Burnus
Date May 7, 2011, 5:21 a.m.
Message ID <4DC4D6CA.5040803@net-b.de>
Download mbox | patch
Permalink /patch/94471/
State New
Headers show

Comments

Tobias Burnus - May 7, 2011, 5:21 a.m.
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
Steve Kargl - May 14, 2011, 1:09 a.m.
On Sat, May 07, 2011 at 07:21:14AM +0200, Tobias Burnus wrote:
> 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?
> 

OK.

Patch

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.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 1f75724..732a0c5 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -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)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 63f03de..a78b5ac 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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)
 	    {
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 22a2c5b..4dd82ca 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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,
--- /dev/null	2011-05-06 19:43:06.071892303 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_20.f90	2011-05-07 00:40:46.000000000 +0200
@@ -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
--- /dev/null	2011-05-06 19:43:06.071892303 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray/image_index_2.f90	2011-05-07 00:28:14.000000000 +0200
@@ -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