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

2011-04-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * iresolve.c (gfc_resolve_image_index): Set ts.type.
        * simplify.c (gfc_simplify_image_index): Don't abort if the
        * bounds
        are not known at compile time and handle -fcoarray=lib.
        * trans-intrinsics.c (gfc_conv_intrinsic_function): Handle
        IMAGE_INDEX.
        (conv_intrinsic_cobound): Fix comment typo.
        (trans_this_image): New function.
        * trans-array.c (gfc_unlikely): Move to trans.c.
        * trans.c (gfc_unlikely): Function moved from trans-array.c.
        (gfc_trans_runtime_check): Use it.
        * trans-io.c (gfc_trans_io_runtime_check): Ditto.
        * trans.h (gfc_unlikely): Add prototype.

2011-04-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_16.f90: New.

From-SVN: r172637

10 files changed, 285 insertions, 38 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 97f3410..7154e62 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,19 @@
+2011-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* iresolve.c (gfc_resolve_image_index): Set ts.type.
+	* simplify.c (gfc_simplify_image_index): Don't abort if the bounds
+	are not known at compile time and handle -fcoarray=lib.
+	* trans-intrinsics.c (gfc_conv_intrinsic_function): Handle
+	IMAGE_INDEX.
+	(conv_intrinsic_cobound): Fix comment typo.
+	(trans_this_image): New function.
+	* trans-array.c (gfc_unlikely): Move to trans.c.
+	* trans.c (gfc_unlikely): Function moved from trans-array.c.
+	(gfc_trans_runtime_check): Use it.
+	* trans-io.c (gfc_trans_io_runtime_check): Ditto.
+	* trans.h (gfc_unlikely): Add prototype.
+
 2011-04-18  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/48462
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 5042db3..24c9f76 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2547,9 +2547,10 @@ void
 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 			 gfc_expr *sub ATTRIBUTE_UNUSED)
 {
-  static char this_image[] = "__image_index";
+  static char image_index[] = "__image_index";
+  f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind;
-  f->value.function.name = this_image;
+  f->value.function.name = image_index;
 }
 
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index abc3383..b744a21 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6189,7 +6189,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
   int d;
 
   if (!is_constant_array_expr (sub))
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* Follow any component references.  */
   as = coarray->symtree->n.sym->as;
@@ -6198,7 +6198,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
      the cosubscript addresses the first image.  */
@@ -6221,7 +6221,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
 				     NULL, true);
       if (ca_bound == NULL)
-	goto not_implemented; /* return NULL */
+	return NULL;
 
       if (ca_bound == &gfc_bad_expr)
 	return ca_bound;
@@ -6285,6 +6285,10 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       return &gfc_bad_expr;
     }
 
+
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+    return NULL;
+
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
   if (first_image)
@@ -6293,11 +6297,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
     mpz_set_si (result->value.integer, 0);
 
   return result;
-
-not_implemented:
-  gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
-	     "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 638234e..5293fec 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4111,21 +4111,6 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 }
 
 
-/* Helper function for marking a boolean expression tree as unlikely.  */
-
-static tree
-gfc_unlikely (tree cond)
-{
-  tree tmp;
-
-  cond = fold_convert (long_integer_type_node, cond);
-  tmp = build_zero_cst (long_integer_type_node);
-  cond = build_call_expr_loc (input_location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-  cond = fold_convert (boolean_type_node, cond);
-  return cond;
-}
-
 /* Fills in an array descriptor, and returns the size of the array.
    The size will be a simple_val, ie a variable or a constant.  Also
    calculates the offset of the base.  The pointer argument overflow,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index bb9d7e1..aec670d 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -921,6 +921,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
   se->expr = fold_convert (type, res);
 }
 
+
 static void
 trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
 {
@@ -928,6 +929,133 @@ trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
   se->expr = gfort_gvar_caf_this_image;
 }
 
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+  tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+       tmp, invalid_bound;
+  gfc_se argse, subse;
+  gfc_ss *ss, *subss;
+  int rank, corank, codim;
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (expr->value.function.actual->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  ss->data.info.codimen = corank;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  /* Obtain a handle to the SUB argument.  */
+  gfc_init_se (&subse, NULL);
+  subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+  gcc_assert (subss != gfc_ss_terminator);
+  gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+			    subss);
+  gfc_add_block_to_block (&se->pre, &subse.pre);
+  gfc_add_block_to_block (&se->post, &subse.post);
+  subdesc = build_fold_indirect_ref_loc (input_location,
+			gfc_conv_descriptor_data_get (subse.expr));
+
+  /* Fortran 2008 does not require that the values remain in the cobounds,
+     thus we need explicitly check this - and return 0 if they are exceeded.  */
+
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+  invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				 fold_convert (gfc_array_index_type, tmp),
+				 lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      lbound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      ubound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+    }
+
+  invalid_bound = gfc_unlikely (invalid_bound);
+
+
+  /* See Fortran 2008, C.10 for the following algorithm.  */
+
+  /* coindex = sub(corank) - lcobound(n).  */
+  coindex = fold_convert (gfc_array_index_type,
+			  gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+					       NULL));
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     fold_convert (gfc_array_index_type, coindex),
+			     lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      tree extent, ubound;
+
+      /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+      /* coindex *= extent.  */
+      coindex = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, coindex, extent);
+
+      /* coindex += sub(codim).  */
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      coindex = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, coindex,
+				 fold_convert (gfc_array_index_type, tmp));
+
+      /* coindex -= lbound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      coindex = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, coindex, lbound);
+    }
+
+  coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+			     fold_convert(type, coindex),
+			     build_int_cst (type, 1));
+
+  /* Return 0 if "coindex" exceeds num_images().  */
+
+  if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+    num_images = build_int_cst (type, 1);
+  else
+    {
+      gfc_init_coarray_decl ();
+      num_images = gfort_gvar_caf_num_images;
+    }
+
+  tmp = gfc_create_var (type, NULL);
+  gfc_add_modify (&se->pre, tmp, coindex);
+
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+			  num_images);
+  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			  cond,
+			  fold_convert (boolean_type_node, invalid_bound));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			      build_int_cst (type, 0), tmp);
+}
+
+
 static void
 trans_num_images (gfc_se * se)
 {
@@ -1233,7 +1361,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
 	   ceiling (real (num_images ()) / real (size)) - 1
 	 = (num_images () + size - 1) / size - 1
 	 = (num_images - 1) / size(),
-         where size is the product of the extend of all but the last
+         where size is the product of the extent of all but the last
 	 codimension.  */
 
       if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
@@ -6312,6 +6440,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	trans_this_image (se, expr);
       break;
 
+    case GFC_ISYM_IMAGE_INDEX:
+      trans_image_index (se, expr);
+      break;
+
     case GFC_ISYM_NUM_IMAGES:
       trans_num_images (se);
       break;
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index f6a783f..883ec5c 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -267,13 +267,7 @@ gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
     }
   else
     {
-      /* Tell the compiler that this isn't likely.  */
-      cond = fold_convert (long_integer_type_node, cond);
-      tmp = build_int_cst (long_integer_type_node, 0);
-      cond = build_call_expr_loc (input_location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-      cond = fold_convert (boolean_type_node, cond);
-
+      cond = gfc_unlikely (cond);
       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
       gfc_add_expr_to_block (pblock, tmp);
     }
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 27a352a..9786d97 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -505,11 +505,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
       else
 	cond = fold_convert (long_integer_type_node, cond);
 
-      tmp = build_int_cst (long_integer_type_node, 0);
-      cond = build_call_expr_loc (where->lb->location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-      cond = fold_convert (boolean_type_node, cond);
-
+      cond = gfc_unlikely (cond);
       tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
 			     cond, body,
 			     build_empty_stmt (where->lb->location));
@@ -1565,3 +1561,19 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block)
 
   return result;
 }
+
+
+/* Helper function for marking a boolean expression tree as unlikely.  */
+
+tree
+gfc_unlikely (tree cond)
+{
+  tree tmp;
+
+  cond = fold_convert (long_integer_type_node, cond);
+  tmp = build_zero_cst (long_integer_type_node);
+  cond = build_call_expr_loc (input_location,
+			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+  cond = fold_convert (boolean_type_node, cond);
+  return cond;
+}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 543ad52..6a2e4f5 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -512,6 +512,9 @@ void gfc_generate_constructors (void);
 /* Get the string length of an array constructor.  */
 bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
 
+/* Mark a condition as unlikely.  */
+tree gfc_unlikely (tree);
+
 /* Generate a runtime error call.  */
 tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4d3019e..22a33c3 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_16.f90: New.
+
 2011-04-18  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/48462
diff --git a/gcc/testsuite/gfortran.dg/coarray_16.f90 b/gcc/testsuite/gfortran.dg/coarray_16.f90
new file mode 100644
index 0000000..282e870
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_16.f90
@@ -0,0 +1,100 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! 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, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:]
+integer, save :: d(2)[-1:3, *]
+integer, save :: e(2)[-1:-1, 3:*]
+
+one = num_images() == 1
+
+allocate(a(1)[3:3, -4:-3, 88:*])
+allocate(b(2)[-1:0,0:*])
+allocate(c(3,3)[*])
+
+index1 = image_index(a, [3, -4, 88] )
+index2 = image_index(b, [-1, 0] )
+index3 = image_index(c, [1] )
+if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+index1 = image_index(a, [3, -3, 88] )
+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 (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+  call abort()
+
+
+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, a,b,c)
+
+! The following test is in honour of the F2008 standard:
+deallocate(a)
+allocate(a (10) [10, 0:9, 0:*])
+
+index1 = image_index(a, [1, 0, 0] )
+index2 = image_index(a, [3, 1, 2] )  ! = 213, yeah!
+index3 = image_index(a, [3, 1, 0] )  ! = 13
+
+if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) &
+  call abort()
+if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) &
+  call abort()
+if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) &
+  call abort()
+
+
+contains
+subroutine test(n, a, b, c)
+  integer :: n
+  integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*]
+
+  index1 = image_index(a, [3, -4, 88] )
+  index2 = image_index(b, [-1, 0] )
+  index3 = image_index(c, [1] )
+  if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+  index1 = image_index(a, [3, -3, 88] )
+  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 (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+    call abort()
+end subroutine test
+end program test_image_index