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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0a4872c55c0f393841c2c0ea8a7d95290548204f..68440f4c840758362ea33f92ce91fa1fb3e729af 100644 (file)
--- 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 2a994454b059a64970cde058d68fc52de7ed83b5..abc33837e6cbbb1206dbe3cfe857549866e02814 100644 (file)
--- 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 0046d0ac10334f5db25cd35f5469f7e47debbdb0..f8e26b0992e16e697f9abee05c01a93b4f176b44 100644 (file)
--- 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 1b3575969151829d2f88362e9f6201bf91b217e6..fef56ae8535b14da14ff35cd504ba0b70ff2209c 100644 (file)
--- 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 1a90204a2da2841dd57120a71a1a02e91891866d..b4cc360706de342fa371e404a8ed192b9326c9c3 100644 (file)
--- 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;