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

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

        PR fortran/18918
        * simplify.c (simplify_bound_dim): Exit for
        ucobound's last dimension unless -fcoarray=single.
        * trans-array (gfc_conv_descriptor_size_1): Renamed from
        gfc_conv_descriptor_size, made static, has now from_dim and
        to_dim arguments.
        (gfc_conv_descriptor_size): Call gfc_conv_descriptor_size.
        (gfc_conv_descriptor_cosize): New function.
        * trans-array.h (gfc_conv_descriptor_cosize): New prototype.
        * trans-intrinsic.c (conv_intrinsic_cobound): Add input_location
        and handle last codim of ucobound for when -fcoarray is not "single".

From-SVN: r172262

5 files changed, 107 insertions, 23 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0a4872c..68440f4 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2011-04-11  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* simplify.c (simplify_bound_dim): Exit for
+	ucobound's last dimension unless -fcoarray=single.
+	* trans-array (gfc_conv_descriptor_size_1): Renamed from
+	gfc_conv_descriptor_size, made static, has now from_dim and
+	to_dim arguments.
+	(gfc_conv_descriptor_size): Call gfc_conv_descriptor_size.
+	(gfc_conv_descriptor_cosize): New function.
+	* trans-array.h (gfc_conv_descriptor_cosize): New prototype.
+	* trans-intrinsic.c (conv_intrinsic_cobound): Add input_location
+	and handle last codim of ucobound for when -fcoarray is not "single".
+
 2011-04-08  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/48448
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2a99445..abc3383 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3298,7 +3298,8 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 
   /* The last dimension of an assumed-size array is special.  */
   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
-      || (coarray && d == as->rank + as->corank))
+      || (coarray && d == as->rank + as->corank
+	  && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
     {
       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
 	{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0046d0ac..f8e26b0 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4055,17 +4055,17 @@ gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
 
 
 /* For an array descriptor, get the total number of elements.  This is just
-   the product of the extents along all dimensions.  */
+   the product of the extents along from_dim to to_dim.  */
 
-tree
-gfc_conv_descriptor_size (tree desc, int rank)
+static tree
+gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
 {
   tree res;
   int dim;
 
   res = gfc_index_one_node;
 
-  for (dim = 0; dim < rank; ++dim)
+  for (dim = from_dim; dim < to_dim; ++dim)
     {
       tree lbound;
       tree ubound;
@@ -4083,6 +4083,24 @@ gfc_conv_descriptor_size (tree desc, int rank)
 }
 
 
+/* Full size of an array.  */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+  return gfc_conv_descriptor_size_1 (desc, 0, rank);
+}
+
+
+/* Size of a coarray for all dimensions but the last.  */
+
+tree
+gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
+{
+  return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
+}
+
+
 /* Helper function for marking a boolean expression tree as unlikely.  */
 
 static tree
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1b35759..fef56ae 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -164,3 +164,4 @@ void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
 /* Calculate extent / size of an array.  */
 tree gfc_conv_array_extent_dim (tree, tree, tree*);
 tree gfc_conv_descriptor_size (tree, int);
+tree gfc_conv_descriptor_cosize (tree, int, int);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1a90204..b4cc360 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1170,10 +1170,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
       tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind);
 
       bound = se->loop->loopvar[0];
-      bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
-			   se->ss->data.info.delta[0]);
-      bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
-			   tree_rank);
+      bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       bound, se->ss->data.info.delta[0]);
+      bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			       bound, tree_rank);
       gfc_advance_se_ss_chain (se);
     }
   else
@@ -1199,11 +1199,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
       else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
         {
 	  bound = gfc_evaluate_now (bound, &se->pre);
-	  cond = fold_build2 (LT_EXPR, boolean_type_node,
-			      bound, build_int_cst (TREE_TYPE (bound), 1));
+	  cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  bound, build_int_cst (TREE_TYPE (bound), 1));
 	  tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
-	  tmp = fold_build2 (GT_EXPR, boolean_type_node, bound, tmp);
-	  cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
+	  tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 bound, tmp);
+	  cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				  boolean_type_node, cond, tmp);
 	  gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
 				   gfc_msg_fault);
 	}
@@ -1213,26 +1215,74 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
       switch (arg->expr->rank)
 	{
 	case 0:
-	  bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
-			       gfc_index_one_node);
+	  bound = fold_build2_loc (input_location, MINUS_EXPR,
+				   gfc_array_index_type, bound,
+				   gfc_index_one_node);
 	case 1:
 	  break;
 	default:
-	  bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound,
-			       gfc_rank_cst[arg->expr->rank - 1]);
+	  bound = fold_build2_loc (input_location, PLUS_EXPR,
+				   gfc_array_index_type, bound,
+				   gfc_rank_cst[arg->expr->rank - 1]);
 	}
     }
 
   resbound = gfc_conv_descriptor_lbound_get (desc, bound);
 
+  /* Handle UCOBOUND with special handling of the last codimension.  */
   if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
     {
-      cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
-			  build_int_cst (TREE_TYPE (bound),
-			  arg->expr->rank + corank - 1));
-      resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
-      se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
-			      resbound, resbound2);
+      /* Last codimension: For -fcoarray=single just return
+	 the lcobound - otherwise add
+	   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
+	 codimension.  */
+
+      if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+	{
+          tree cosize;
+
+	  gfc_init_coarray_decl ();
+	  cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfort_gvar_caf_num_images,
+				 build_int_cst (gfc_array_index_type, 1));
+	  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+				 gfc_array_index_type, tmp,
+				 fold_convert (gfc_array_index_type, cosize));
+	  resbound = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, resbound, tmp);
+	}
+      else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+	{
+	  /* ubound = lbound + num_images() - 1.  */
+	  gfc_init_coarray_decl ();
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type,
+				 gfort_gvar_caf_num_images,
+				 build_int_cst (gfc_array_index_type, 1));
+	  resbound = fold_build2_loc (input_location, PLUS_EXPR,
+				      gfc_array_index_type, resbound, tmp);
+	}
+
+      if (corank > 1)
+	{
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  bound,
+				  build_int_cst (TREE_TYPE (bound),
+						 arg->expr->rank + corank - 1));
+
+	  resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+	  se->expr = fold_build3_loc (input_location, COND_EXPR,
+				      gfc_array_index_type, cond,
+				      resbound, resbound2);
+	}
+      else
+	se->expr = resbound;
     }
   else
     se->expr = resbound;