re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2011-05-15  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        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-15  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray/image_index_2.f90: New.

From-SVN: r173772

gcc/fortran/ChangeLog

@@ -1,3 +1,11 @@
+2011-05-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	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-15  Joern Rennecke  <amylaar@spamcop.net>
 
 	PR middle-end/46500

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)
 	    {

gcc/fortran/trans-types.c

@@ -1683,9 +1683,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];
@@ -1700,6 +1701,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)
 	{
@@ -1709,6 +1713,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,

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2011-05-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray/image_index_2.f90: New.
+
 2011-05-13  Ville Voutilainen  <ville.voutilainen@gmail.com>
 
 	* g++.dg/cpp0x/override1.C: Move from inherit/virtual9.C.

gcc/testsuite/gfortran.dg/coarray/image_index_2.f90

@@ -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