re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])
authorTobias Burnus <burnus@net-b.de>
Mon, 4 Apr 2011 18:35:13 +0000 (20:35 +0200)
committerTobias Burnus <burnus@gcc.gnu.org>
Mon, 4 Apr 2011 18:35:13 +0000 (20:35 +0200)
2011-04-04  Tobias Burnus  <burnus@net-b.de>
            Mikael Morin  <mikael.morin@sfr.fr>

        PR fortran/18918
        * check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE.
        * expr.c (gfc_is_coindexed): Ditto.
        * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE.
        * interface.c (compare_parameter): Use gfc_expr_attr and
        gfc_is_coindexed.
        * resolve.c (check_dimension, compare_spec_to_ref,
        resolve_allocate_expr, check_data_variable): Update for
        DIMEN_THIS_IMAGE.
        * simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image,
        gfc_simplify_ucobound): Allow non-constant bounds.
        * trans-array.c (gfc_set_loop_bounds_from_array_spec,
        gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
        gfc_set_vector_loop_bounds, gfc_conv_array_index_offset,
        gfc_start_scalarized_body, gfc_trans_scalarizing_loops,
        gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
        gfc_conv_ss_startstride, gfc_conv_loop_setup,
        gfc_trans_array_bounds, gfc_conv_expr_descriptor,
        gfc_walk_variable_expr): Handle codimen.
        * trans-decl.c (gfc_build_qualified_array): Save cobounds.
        * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2.
        (conv_intrinsic_cobound): New function.
        (gfc_conv_intrinsic_function): Call it.
        (gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle
        ucobound, lcobound, this_image.
        * fortran/trans-types.c (gfc_build_array_type): Save cobounds.
        (gfc_get_dtype): Honour corank.
        (gfc_get_nodesc_array_type): Save corank and codimensions.
        (gfc_get_array_type_bounds): Save cobound.
        * fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item.
        (gfc_array_kind): Add corank item.
        (GFC_TYPE_ARRAY_CORANK): New macro.

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

        PR fortran/18918
        * gfortran.dg/coarray_10.f90: Add coarray descriptor diagnostic
        check.
        * gfortran.dg/coarray_13.f90: Add checks for run-time cobounds.
        * gfortran.dg/coarray_15.f90: New.

Co-Authored-By: Mikael Morin <mikael.morin@sfr.fr>
From-SVN: r171949

16 files changed:
gcc/fortran/ChangeLog
gcc/fortran/check.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/interface.c
gcc/fortran/resolve.c
gcc/fortran/simplify.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-types.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/coarray_10.f90
gcc/testsuite/gfortran.dg/coarray_13.f90
gcc/testsuite/gfortran.dg/coarray_15.f90 [new file with mode: 0644]

index 16d824ae6eba62c46779bc95139c047eefd332a2..f9513dbf650f4997e922fafef5679cde8b66b169 100644 (file)
@@ -1,3 +1,39 @@
+2011-04-04  Tobias Burnus  <burnus@net-b.de>
+           Mikael Morin  <mikael.morin@sfr.fr>
+
+       PR fortran/18918
+       * check.c (is_coarray): Update - because of DIMEN_THIS_IMAGE.
+       * expr.c (gfc_is_coindexed): Ditto.
+       * gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_THIS_IMAGE.
+       * interface.c (compare_parameter): Use gfc_expr_attr and
+       gfc_is_coindexed.
+       * resolve.c (check_dimension, compare_spec_to_ref,
+       resolve_allocate_expr, check_data_variable): Update for
+       DIMEN_THIS_IMAGE.
+       * simplify.c (gfc_simplify_lcobound, gfc_simplify_this_image,
+       gfc_simplify_ucobound): Allow non-constant bounds.
+       * trans-array.c (gfc_set_loop_bounds_from_array_spec,
+       gfc_trans_create_temp_array, gfc_trans_constant_array_constructor,
+       gfc_set_vector_loop_bounds, gfc_conv_array_index_offset,
+       gfc_start_scalarized_body, gfc_trans_scalarizing_loops,
+       gfc_trans_scalarized_loop_boundary, gfc_conv_section_startstride,
+       gfc_conv_ss_startstride, gfc_conv_loop_setup,
+       gfc_trans_array_bounds, gfc_conv_expr_descriptor,
+       gfc_walk_variable_expr): Handle codimen.
+       * trans-decl.c (gfc_build_qualified_array): Save cobounds.
+       * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2.
+       (conv_intrinsic_cobound): New function.
+       (gfc_conv_intrinsic_function): Call it.
+       (gfc_walk_intrinsic_function, gfc_add_intrinsic_ss_code): Handle
+       ucobound, lcobound, this_image.
+       * fortran/trans-types.c (gfc_build_array_type): Save cobounds.
+       (gfc_get_dtype): Honour corank.
+       (gfc_get_nodesc_array_type): Save corank and codimensions.
+       (gfc_get_array_type_bounds): Save cobound.
+       * fortran/trans.h (gfc_ss_info,gfc_loopinfo): Add codimen item.
+       (gfc_array_kind): Add corank item.
+       (GFC_TYPE_ARRAY_CORANK): New macro.
+
 2011-04-03  Kai Tietz  <ktietz@redhat.com>
 
        PR middle-end/48422
index adb4b95368d3205befcdeabc955641f745e5b206..bb56122137e44f0f042def053be36cb16b601606 100644 (file)
@@ -219,9 +219,15 @@ is_coarray (gfc_expr *e)
     {
       if (ref->type == REF_COMPONENT)
        coarray = ref->u.c.component->attr.codimension;
-      else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
-              || ref->u.ar.codimen != 0) 
+      else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0)
        coarray = false;
+      else if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) 
+       {
+         int n;
+         for (n = 0; n < ref->u.ar.codimen; n++)
+           if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+             coarray = false;
+       }
     }
 
   return coarray;
index 58b6036094a6268dae17ee00fca489913629b49d..287a2a24e3c4cbee6681ae4b772daff1bc401b18 100644 (file)
@@ -4129,7 +4129,12 @@ gfc_is_coindexed (gfc_expr *e)
 
   for (ref = e->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
-      return true;
+      {
+       int n;
+       for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+         if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+           return true;
+      }
 
   return false;
 }
index eec737c10c0085e5b76974d0a0adf51bbb885509..495923a2466aa804e3dffcf6ccddcc93e55f5bf5 100644 (file)
@@ -1486,7 +1486,7 @@ extern gfc_interface_info current_interface;
 
 enum gfc_array_ref_dimen_type
 {
-  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
+  DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_THIS_IMAGE, DIMEN_UNKNOWN
 };
 
 typedef struct gfc_array_ref
index b0b74c14b9f6583a6ca3ec06cd633eefd6ee170e..00fd24ac247bf4d0868d52a7fb7ae0da1b9b5772 100644 (file)
@@ -1564,8 +1564,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       gfc_ref *last = NULL;
 
       if (actual->expr_type != EXPR_VARIABLE
-         || (actual->ref == NULL
-             && !actual->symtree->n.sym->attr.codimension))
+         || !gfc_expr_attr (actual).codimension)
        {
          if (where)
            gfc_error ("Actual argument to '%s' at %L must be a coarray",
@@ -1573,15 +1572,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
          return 0;
        }
 
+      if (gfc_is_coindexed (actual))
+       {
+         if (where)
+           gfc_error ("Actual argument to '%s' at %L must be a coarray "
+                      "and not coindexed", formal->name, &actual->where);
+         return 0;
+       }
+
       for (ref = actual->ref; ref; ref = ref->next)
        {
-         if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
-           {
-             if (where)
-               gfc_error ("Actual argument to '%s' at %L must be a coarray "
-                          "and not coindexed", formal->name, &ref->u.ar.where);
-             return 0;
-           }
          if (ref->type == REF_ARRAY && ref->u.ar.as->corank
              && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
            {
@@ -1595,14 +1595,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
            last = ref;
        }
 
-      if (last && !last->u.c.component->attr.codimension)
-       {
-         if (where)
-           gfc_error ("Actual argument to '%s' at %L must be a coarray",
-                      formal->name, &actual->where);
-         return 0;
-       }
-
       /* F2008, 12.5.2.6.  */
       if (formal->attr.allocatable &&
          ((last && last->u.c.component->as->corank != formal->as->corank)
index 1fef22b2469930634d0aace756d49b915838f972..01999e5f250846573d460c1d2a573346c895083e 100644 (file)
@@ -4157,6 +4157,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
   switch (ar->dimen_type[i])
     {
     case DIMEN_VECTOR:
+    case DIMEN_THIS_IMAGE:
       break;
 
     case DIMEN_STAR:
@@ -4324,7 +4325,8 @@ compare_spec_to_ref (gfc_array_ref *ar)
   if (ar->codimen != 0)
     for (i = as->rank; i < as->rank + as->corank; i++)
       {
-       if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+       if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate
+           && ar->dimen_type[i] != DIMEN_THIS_IMAGE)
          {
            gfc_error ("Coindex of codimension %d must be a scalar at %L",
                       i + 1 - as->rank, &ar->where);
@@ -4334,6 +4336,14 @@ compare_spec_to_ref (gfc_array_ref *ar)
          return FAILURE;
       }
 
+  if (as->corank && ar->codimen == 0)
+    {
+      int n;
+      ar->codimen = as->corank;
+      for (n = ar->dimen; n < ar->dimen + ar->codimen; n++)
+       ar->dimen_type[n] = DIMEN_THIS_IMAGE;
+    }
+
   return SUCCESS;
 }
 
@@ -6848,12 +6858,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   ar = &ref2->u.ar;
 
-  if (codimension && ar->codimen == 0)
-    {
-      gfc_error ("Coarray specification required in ALLOCATE statement "
-                "at %L", &e->where);
-      goto failure;
-    }
+  if (codimension)
+    for (i = ar->dimen; i < ar->dimen + ar->codimen; i++)
+      if (ar->dimen_type[i] == DIMEN_THIS_IMAGE)
+       {
+         gfc_error ("Coarray specification required in ALLOCATE statement "
+                    "at %L", &e->where);
+         goto failure;
+       }
 
   for (i = 0; i < ar->dimen; i++)
     {
@@ -6876,6 +6888,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
        case DIMEN_UNKNOWN:
        case DIMEN_VECTOR:
        case DIMEN_STAR:
+       case DIMEN_THIS_IMAGE:
          gfc_error ("Bad array specification in ALLOCATE statement at %L",
                     &e->where);
          goto failure;
@@ -12501,18 +12514,18 @@ check_data_variable (gfc_data_variable *var, locus *where)
 
   has_pointer = sym->attr.pointer;
 
+  if (gfc_is_coindexed (e))
+    {
+      gfc_error ("DATA element '%s' at %L cannot have a coindex", sym->name,
+                where);
+      return FAILURE;
+    }
+
   for (ref = e->ref; ref; ref = ref->next)
     {
       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
        has_pointer = 1;
 
-      if (ref->type == REF_ARRAY && ref->u.ar.codimen)
-       {
-         gfc_error ("DATA element '%s' at %L cannot have a coindex",
-                    sym->name, where);
-         return FAILURE;
-       }
-
       if (has_pointer
            && ref->type == REF_ARRAY
            && ref->u.ar.type != AR_FULL)
index 69edad8e0b5a13f19229c2adc5a997954100ccde..2a994454b059a64970cde058d68fc52de7ed83b5 100644 (file)
@@ -3632,16 +3632,7 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 0);*/
-
-  e = simplify_cobound (array, dim, kind, 0);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
-            "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 0);
 }
 
 gfc_expr *
@@ -6338,7 +6329,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   if (dim == NULL)
     {
@@ -6357,8 +6348,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 
              for (j = 0; j < d; j++)
                gfc_free_expr (bounds[j]);
-             if (bounds[d] == NULL)
-               goto not_implemented;
+
              return bounds[d];
            }
        }
@@ -6383,10 +6373,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
     }
   else
     {
-      gfc_expr *e;
       /* A DIM argument is specified.  */
       if (dim->expr_type != EXPR_CONSTANT)
-       goto not_implemented; /*return NULL;*/
+       return NULL;
 
       d = mpz_get_si (dim->value.integer);
 
@@ -6396,18 +6385,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
          return &gfc_bad_expr;
        }
 
-      /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
-      e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
-      if (e != NULL)
-       return e;
-      else
-       goto not_implemented;
+      return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
+                                true);
    }
-
-not_implemented:
-  gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
-            "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
@@ -6420,16 +6400,7 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 gfc_expr *
 gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  gfc_expr *e;
-  /* return simplify_cobound (array, dim, kind, 1);*/
-
-  e = simplify_cobound (array, dim, kind, 1);
-  if (e != NULL)
-    return e;
-
-  gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
-            "cobounds at %L", &array->where);
-  return &gfc_bad_expr;
+  return simplify_cobound (array, dim, kind, 1);
 }
 
 
index ac08c42c94436a91a78dbe65271d1f7220af705b..0046d0ac10334f5db25cd35f5469f7e47debbdb0 100644 (file)
@@ -562,7 +562,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
   tree tmp;
 
   if (as && as->type == AS_EXPLICIT)
-    for (n = 0; n < se->loop->dimen; n++)
+    for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
       {
        dim = se->ss->data.info.dim[n];
        gcc_assert (dim < as->rank);
@@ -576,18 +576,22 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
            gfc_add_block_to_block (&se->post, &tmpse.post);
            lower = fold_convert (gfc_array_index_type, tmpse.expr);
 
-           /* ...and the upper bound.  */
-           gfc_init_se (&tmpse, NULL);
-           gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
-           gfc_add_block_to_block (&se->pre, &tmpse.pre);
-           gfc_add_block_to_block (&se->post, &tmpse.post);
-           upper = fold_convert (gfc_array_index_type, tmpse.expr);
-
-           /* Set the upper bound of the loop to UPPER - LOWER.  */
-           tmp = fold_build2_loc (input_location, MINUS_EXPR,
-                                  gfc_array_index_type, upper, lower);
-           tmp = gfc_evaluate_now (tmp, &se->pre);
-           se->loop->to[n] = tmp;
+           if (se->loop->codimen == 0
+               || n < se->loop->dimen + se->loop->codimen - 1)
+             {
+               /* ...and the upper bound.  */
+               gfc_init_se (&tmpse, NULL);
+               gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+               gfc_add_block_to_block (&se->pre, &tmpse.pre);
+               gfc_add_block_to_block (&se->post, &tmpse.post);
+               upper = fold_convert (gfc_array_index_type, tmpse.expr);
+
+               /* Set the upper bound of the loop to UPPER - LOWER.  */
+               tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                      gfc_array_index_type, upper, lower);
+               tmp = gfc_evaluate_now (tmp, &se->pre);
+               se->loop->to[n] = tmp;
+             }
          }
       }
 }
@@ -885,6 +889,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
                              size, tmp);
       size = gfc_evaluate_now (size, pre);
     }
+  for (n = info->dimen; n < info->dimen + info->codimen; n++)
+    {
+      gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+                                      gfc_index_zero_node);
+      if (n < info->dimen + info->codimen - 1)
+       gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
+    }
 
   /* Get the size of the array.  */
 
@@ -1777,7 +1788,7 @@ gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
   info->data = gfc_build_addr_expr (NULL_TREE, tmp);
   info->offset = gfc_index_zero_node;
 
-  for (i = 0; i < info->dimen; i++)
+  for (i = 0; i < info->dimen + info->codimen; i++)
     {
       info->delta[i] = gfc_index_zero_node;
       info->start[i] = gfc_index_zero_node;
@@ -2018,7 +2029,7 @@ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
   int n;
   int dim;
 
-  for (n = 0; n < loop->dimen; n++)
+  for (n = 0; n < loop->dimen + loop->codimen; n++)
     {
       dim = info->dim[n];
       if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
@@ -2452,6 +2463,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
       gcc_assert (ar->type != AR_ELEMENT);
       switch (ar->dimen_type[dim])
        {
+       case DIMEN_THIS_IMAGE:
+         gcc_unreachable ();
+         break;
        case DIMEN_ELEMENT:
          /* Elemental dimension.  */
          gcc_assert (info->subscript[dim]
@@ -2813,7 +2827,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
 
   gcc_assert (!loop->array_parameter);
 
-  for (dim = loop->dimen - 1; dim >= 0; dim--)
+  for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
     {
       n = loop->order[dim];
 
@@ -2967,7 +2981,7 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
 
   pblock = body;
   /* Generate the loops.  */
-  for (dim = 0; dim < loop->dimen; dim++)
+  for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
     {
       n = loop->order[dim];
       gfc_trans_scalarized_loop_end (loop, n, pblock);
@@ -3043,11 +3057,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
 /* Calculate the lower bound of an array section.  */
 
 static void
-gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
+gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
+                             bool coarray, bool coarray_last)
 {
   gfc_expr *start;
   gfc_expr *end;
-  gfc_expr *stride;
+  gfc_expr *stride = NULL;
   tree desc;
   gfc_se se;
   gfc_ss_info *info;
@@ -3060,8 +3075,9 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
     {
       /* We use a zero-based index to access the vector.  */
       info->start[dim] = gfc_index_zero_node;
-      info->stride[dim] = gfc_index_one_node;
       info->end[dim] = NULL;
+      if (!coarray)
+       info->stride[dim] = gfc_index_one_node;
       return;
     }
 
@@ -3069,7 +3085,8 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
   desc = info->descriptor;
   start = info->ref->u.ar.start[dim];
   end = info->ref->u.ar.end[dim];
-  stride = info->ref->u.ar.stride[dim];
+  if (!coarray)
+    stride = info->ref->u.ar.stride[dim];
 
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
@@ -3091,25 +3108,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
   /* Similarly calculate the end.  Although this is not used in the
      scalarizer, it is needed when checking bounds and where the end
      is an expression with side-effects.  */
-  if (end)
+  if (!coarray_last)
     {
-      /* Specified section start.  */
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_type (&se, end, gfc_array_index_type);
-      gfc_add_block_to_block (&loop->pre, &se.pre);
-      info->end[dim] = se.expr;
-    }
-  else
-    {
-      /* No upper bound specified so use the bound of the array.  */
-      info->end[dim] = gfc_conv_array_ubound (desc, dim);
+      if (end)
+       {
+         /* Specified section start.  */
+         gfc_init_se (&se, NULL);
+         gfc_conv_expr_type (&se, end, gfc_array_index_type);
+         gfc_add_block_to_block (&loop->pre, &se.pre);
+         info->end[dim] = se.expr;
+       }
+      else
+       {
+         /* No upper bound specified so use the bound of the array.  */
+         info->end[dim] = gfc_conv_array_ubound (desc, dim);
+       }
+      info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
     }
-  info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
 
   /* Calculate the stride.  */
-  if (stride == NULL)
+  if (!coarray && stride == NULL)
     info->stride[dim] = gfc_index_one_node;
-  else
+  else if (!coarray)
     {
       gfc_init_se (&se, NULL);
       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
@@ -3143,6 +3163,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
        case GFC_SS_FUNCTION:
        case GFC_SS_COMPONENT:
          loop->dimen = ss->data.info.dimen;
+         loop->codimen = ss->data.info.codimen;
          break;
 
        /* As usual, lbound and ubound are exceptions!.  */
@@ -3152,6 +3173,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
            case GFC_ISYM_LBOUND:
            case GFC_ISYM_UBOUND:
              loop->dimen = ss->data.info.dimen;
+             loop->codimen = 0;
+             break;
+
+           case GFC_ISYM_LCOBOUND:
+           case GFC_ISYM_UCOBOUND:
+           case GFC_ISYM_THIS_IMAGE:
+             loop->dimen = ss->data.info.dimen;
+             loop->codimen = ss->data.info.codimen;
+             break;
 
            default:
              break;
@@ -3164,7 +3194,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 
   /* We should have determined the rank of the expression by now.  If
      not, that's bad news.  */
-  gcc_assert (loop->dimen != 0);
+  gcc_assert (loop->dimen + loop->codimen != 0);
 
   /* Loop over all the SS in the chain.  */
   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
@@ -3179,7 +3209,14 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
          gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
 
          for (n = 0; n < ss->data.info.dimen; n++)
-           gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
+           gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
+                                         false, false);
+         for (n = ss->data.info.dimen;
+              n < ss->data.info.dimen + ss->data.info.codimen; n++)
+           gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
+                                         n == ss->data.info.dimen
+                                              + ss->data.info.codimen -1);
+
          break;
 
        case GFC_SS_INTRINSIC:
@@ -3188,7 +3225,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
            /* Fall through to supply start and stride.  */
            case GFC_ISYM_LBOUND:
            case GFC_ISYM_UBOUND:
+           case GFC_ISYM_LCOBOUND:
+           case GFC_ISYM_UCOBOUND:
+           case GFC_ISYM_THIS_IMAGE:
              break;
+
            default:
              continue;
            }
@@ -3697,6 +3738,7 @@ temporary:
       loop->temp_ss->data.temp.type = base_type;
       loop->temp_ss->string_length = dest->string_length;
       loop->temp_ss->data.temp.dimen = loop->dimen;
+      loop->temp_ss->data.temp.codimen = loop->codimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
     }
@@ -3725,7 +3767,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
   mpz_t i;
 
   mpz_init (i);
-  for (n = 0; n < loop->dimen; n++)
+  for (n = 0; n < loop->dimen + loop->codimen; n++)
     {
       loopspec[n] = NULL;
       dynamic[n] = false;
@@ -3807,7 +3849,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
             known lower bound
             known upper bound
           */
-         else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+         else if ((loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
+                  || n >= loop->dimen)
            loopspec[n] = ss;
          else if (integer_onep (info->stride[dim])
                   && !integer_onep (specinfo->stride[spec_dim]))
@@ -3833,7 +3876,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 
       /* Set the extents of this range.  */
       cshape = loopspec[n]->shape;
-      if (cshape && INTEGER_CST_P (info->start[dim])
+      if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
          && INTEGER_CST_P (info->stride[dim]))
        {
          loop->from[n] = info->start[dim];
@@ -3877,9 +3920,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
        }
 
       /* Transform everything so we have a simple incrementing variable.  */
-      if (integer_onep (info->stride[dim]))
+      if (n < loop->dimen && integer_onep (info->stride[dim]))
        info->delta[dim] = gfc_index_zero_node;
-      else
+      else if (n < loop->dimen)
        {
          /* Set the delta for this section.  */
          info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre);
@@ -4663,7 +4706,26 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 
       size = stride;
     }
-
+  for (dim = as->rank; dim < as->rank + as->corank; dim++)
+    {
+      /* Evaluate non-constant array bound expressions.  */
+      lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+      if (as->lower[dim] && !INTEGER_CST_P (lbound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, lbound, se.expr);
+        }
+      ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+      if (as->upper[dim] && !INTEGER_CST_P (ubound))
+        {
+          gfc_init_se (&se, NULL);
+          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+          gfc_add_block_to_block (pblock, &se.pre);
+          gfc_add_modify (pblock, ubound, se.expr);
+        }
+    }
   gfc_trans_vla_type_sizes (sym, pblock);
 
   *poffset = offset;
@@ -5626,6 +5688,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 
       se->string_length = loop.temp_ss->string_length;
       loop.temp_ss->data.temp.dimen = loop.dimen;
+      loop.temp_ss->data.temp.codimen = loop.codimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
 
@@ -5689,7 +5752,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
         limits will be the limits of the section.
         A function may decide to repack the array to speed up access, but
         we're not bothered about that here.  */
-      int dim, ndim;
+      int dim, ndim, codim;
       tree parm;
       tree parmtype;
       tree stride;
@@ -5712,8 +5775,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
        {
          /* Otherwise make a new one.  */
          parmtype = gfc_get_element_type (TREE_TYPE (desc));
-         parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
-                                               loop.from, loop.to, 0,
+         parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+                                               loop.codimen, loop.from,
+                                               loop.to, 0,
                                                GFC_ARRAY_UNKNOWN, false);
          parm = gfc_create_var (parmtype, "parm");
        }
@@ -5744,6 +5808,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
        base = NULL_TREE;
 
       ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
+      codim = info->codimen;
       for (n = 0; n < ndim; n++)
        {
          stride = gfc_conv_array_stride (desc, n);
@@ -5845,6 +5910,26 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
                                          gfc_rank_cst[dim], stride);
        }
 
+      for (n = ndim; n < ndim + codim; n++)
+       {
+         /* look for the corresponding scalarizer dimension: dim.  */
+         for (dim = 0; dim < ndim + codim; dim++)
+           if (info->dim[dim] == n)
+             break;
+
+         /* loop exited early: the DIM being looked for has been found.  */
+         gcc_assert (dim < ndim + codim);
+
+         from = loop.from[dim];
+         to = loop.to[dim];
+         gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+                                         gfc_rank_cst[dim], from);
+         if (n < ndim + codim - 1)
+           gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+                                           gfc_rank_cst[dim], to);
+         dim++;
+       }
+
       if (se->data_not_needed)
        gfc_conv_descriptor_data_set (&loop.pre, parm,
                                      gfc_index_zero_node);
@@ -7311,7 +7396,7 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
       switch (ar->type)
        {
        case AR_ELEMENT:
-         for (n = 0; n < ar->dimen; n++)
+         for (n = 0; n < ar->dimen + ar->codimen; n++)
            {
              newss = gfc_get_ss ();
              newss->type = GFC_SS_SCALAR;
@@ -7327,11 +7412,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
          newss->expr = expr;
          newss->next = ss;
          newss->data.info.dimen = ar->as->rank;
+         newss->data.info.codimen = 0;
          newss->data.info.ref = ref;
 
          /* Make sure array is the same as array(:,:), this way
             we don't need to special case all the time.  */
          ar->dimen = ar->as->rank;
+         ar->codimen = 0;
          for (n = 0; n < ar->dimen; n++)
            {
              newss->data.info.dim[n] = n;
@@ -7341,6 +7428,14 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
              gcc_assert (ar->end[n] == NULL);
              gcc_assert (ar->stride[n] == NULL);
            }
+         for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
+           {
+             newss->data.info.dim[n] = n;
+             ar->dimen_type[n] = DIMEN_RANGE;
+
+             gcc_assert (ar->start[n] == NULL);
+             gcc_assert (ar->end[n] == NULL);
+           }
          ss = newss;
          break;
 
@@ -7350,15 +7445,18 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
          newss->expr = expr;
          newss->next = ss;
          newss->data.info.dimen = 0;
+         newss->data.info.codimen = 0;
          newss->data.info.ref = ref;
 
           /* We add SS chains for all the subscripts in the section.  */
-         for (n = 0; n < ar->dimen; n++)
+         for (n = 0; n < ar->dimen + ar->codimen; n++)
            {
              gfc_ss *indexss;
 
              switch (ar->dimen_type[n])
                {
+               case DIMEN_THIS_IMAGE:
+                 continue;
                case DIMEN_ELEMENT:
                  /* Add SS for elemental (scalar) subscripts.  */
                  gcc_assert (ar->start[n]);
@@ -7373,8 +7471,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
                case DIMEN_RANGE:
                   /* We don't add anything for sections, just remember this
                      dimension for later.  */
-                 newss->data.info.dim[newss->data.info.dimen] = n;
-                 newss->data.info.dimen++;
+                 newss->data.info.dim[newss->data.info.dimen
+                                      + newss->data.info.codimen] = n;
+                 if (n < ar->dimen)
+                   newss->data.info.dimen++;
                  break;
 
                case DIMEN_VECTOR:
@@ -7386,8 +7486,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
                  indexss->next = gfc_ss_terminator;
                  indexss->loop_chain = gfc_ss_terminator;
                  newss->data.info.subscript[n] = indexss;
-                 newss->data.info.dim[newss->data.info.dimen] = n;
-                 newss->data.info.dimen++;
+                 newss->data.info.dim[newss->data.info.dimen
+                                      + newss->data.info.codimen] = n;
+                 if (n < ar->dimen)
+                   newss->data.info.dimen++;
                  break;
 
                default:
index a0bbe537795c51f49054a3716d100d6ac7808e01..cc6fced4c0cd8187df83a31a0414895c62008514 100644 (file)
@@ -767,6 +767,22 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
          TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
        }
     }
+  for (dim = GFC_TYPE_ARRAY_RANK (type);
+       dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
+    {
+      if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
+       {
+         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+         TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+       }
+      /* Don't try to use the unknown ubound for the last coarray dimension.  */
+      if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
+          && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
+       {
+         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+         TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+       }
+    }
   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
     {
       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
index fa3e4c2c060238605441c73eb5bdafd01f593b05..a3c2ecda0c6d3c2a2af63078c4ffe8d750536afd 100644 (file)
@@ -932,6 +932,7 @@ trans_num_images (gfc_se * se)
   se->expr = gfort_gvar_caf_num_images;
 }
 
+
 /* Evaluate a single upper or lower bound.  */
 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 
@@ -969,9 +970,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   else
     {
       /* use the passed argument.  */
-      gcc_assert (arg->next->expr);
+      gcc_assert (arg2->expr);
       gfc_init_se (&argse, NULL);
-      gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
       gfc_add_block_to_block (&se->pre, &argse.pre);
       bound = argse.expr;
       /* Convert from one based to zero based.  */
@@ -1116,6 +1117,128 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 }
 
 
+static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  gfc_se argse;
+  gfc_ss *ss;
+  tree bound, resbound, resbound2, desc, cond, tmp;
+  tree type;
+  gfc_array_spec * as;
+  int corank;
+
+  gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+             || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+             || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
+
+  gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+  corank = gfc_get_corank (arg->expr);
+
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+  gcc_assert (as);
+
+  ss = gfc_walk_expr (arg->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  ss->data.info.codimen = corank;
+  gfc_init_se (&argse, NULL);
+
+  gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  if (se->ss)
+    {
+      mpz_t mpz_rank;
+      tree tree_rank;
+
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (!arg2->expr);
+      gcc_assert (corank > 0);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->expr == expr);
+
+      mpz_init_set_ui (mpz_rank, arg->expr->rank);
+      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);
+      gfc_advance_se_ss_chain (se);
+    }
+  else
+    {
+      /* use the passed argument.  */
+      gcc_assert (arg2->expr);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      bound = argse.expr;
+
+      if (INTEGER_CST_P (bound))
+       {
+         int hi, low;
+
+         hi = TREE_INT_CST_HIGH (bound);
+         low = TREE_INT_CST_LOW (bound);
+         if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+           gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+                      "dimension index", expr->value.function.isym->name,
+                      &expr->where);
+       }
+      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));
+         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);
+         gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+                                  gfc_msg_fault);
+       }
+
+
+      /* Substract 1 to get to zero based and add dimensions.  */
+      switch (arg->expr->rank)
+       {
+       case 0:
+         bound = fold_build2 (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]);
+       }
+    }
+
+  resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+  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);
+    }
+  else
+    se->expr = resbound;
+
+  type = gfc_typenode_for_spec (&expr->ts);
+  se->expr = convert (type, se->expr);
+}
+
+
 static void
 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 {
@@ -5960,6 +6083,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 0);
       break;
 
+    case GFC_ISYM_LCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_TRANSPOSE:
       /* The scalarizer has already been set up for reversed dimension access
         order ; now we just get the argument value normally.  */
@@ -6117,6 +6244,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_bound (se, expr, 1);
       break;
 
+    case GFC_ISYM_UCOBOUND:
+      conv_intrinsic_cobound (se, expr);
+      break;
+
     case GFC_ISYM_XOR:
       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
       break;
@@ -6126,7 +6257,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_THIS_IMAGE:
-      trans_this_image (se, expr);
+      if (expr->value.function.actual)
+       conv_intrinsic_cobound (se, expr);
+      else
+       trans_this_image (se, expr);
       break;
 
     case GFC_ISYM_NUM_IMAGES:
@@ -6261,6 +6395,9 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
     {
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       break;
 
     default:
@@ -6269,8 +6406,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
 }
 
 
-/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
-   inside the scalarization loop.  */
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+   are expanded into code inside the scalarization loop.  */
 
 static gfc_ss *
 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
@@ -6407,7 +6544,10 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
   switch (isym->id)
     {
     case GFC_ISYM_LBOUND:
+    case GFC_ISYM_LCOBOUND:
     case GFC_ISYM_UBOUND:
+    case GFC_ISYM_UCOBOUND:
+    case GFC_ISYM_THIS_IMAGE:
       return gfc_walk_intrinsic_bound (ss, expr);
 
     case GFC_ISYM_TRANSFER:
index 8ecceea8ffd4d52490f0453ed0f1bc735406da60..7e12f08beaf46d3d471395fbd5ac6baef3ae4a78 100644 (file)
@@ -1249,6 +1249,17 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
     }
 
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      if (as->lower[n] == NULL)
+        lbound[n] = gfc_index_one_node;
+      else
+        lbound[n] = gfc_conv_array_bound (as->lower[n]);
+
+      if (n < as->rank + as->corank - 1)
+       ubound[n] = gfc_conv_array_bound (as->upper[n]);
+    }
+
   if (as->type == AS_ASSUMED_SHAPE)
     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
                       : GFC_ARRAY_ASSUMED_SHAPE;
@@ -1477,6 +1488,25 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
       if (packed == PACKED_NO || packed == PACKED_PARTIAL)
         known_stride = 0;
     }
+  for (n = as->rank; n < as->rank + as->corank; n++)
+    {
+      expr = as->lower[n];
+      if (expr->expr_type == EXPR_CONSTANT)
+       tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+                                   gfc_index_integer_kind);
+      else
+       tmp = NULL_TREE;
+      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+
+      expr = as->upper[n];
+      if (expr && expr->expr_type == EXPR_CONSTANT)
+       tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+                                   gfc_index_integer_kind);
+      else
+       tmp = NULL_TREE;
+      if (n < as->rank + as->corank - 1)
+      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+    }
 
   if (known_offset)
     {
@@ -1495,6 +1525,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
     GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
 
   GFC_TYPE_ARRAY_RANK (type) = as->rank;
+  GFC_TYPE_ARRAY_CORANK (type) = as->corank;
   GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
   range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
                            NULL_TREE);
@@ -1654,6 +1685,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
     = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
 
   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
+  GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
   GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
 
index 19e86bb951ab0284a342ab2dc3f7c722e46e1427..543ad525b1aad7d0eb0cda945552e64f6e95085f 100644 (file)
@@ -104,7 +104,7 @@ gfc_se;
 
 typedef struct gfc_ss_info
 {
-  int dimen;
+  int dimen, codimen;
   /* The ref that holds information on this section.  */
   gfc_ref *ref;
   /* The descriptor of this array.  */
@@ -198,7 +198,7 @@ typedef struct gfc_ss
     {
       /* The rank of the temporary.  May be less than the rank of the
          assigned expression.  */
-      int dimen;
+      int dimen, codimen;
       tree type;
     }
     temp;
@@ -231,7 +231,7 @@ typedef struct gfc_loopinfo
   stmtblock_t pre;
   stmtblock_t post;
 
-  int dimen;
+  int dimen, codimen;
 
   /* All the SS involved with this loop.  */
   gfc_ss *ss;
@@ -713,7 +713,7 @@ enum gfc_array_kind
    variable-sized in some other frontends.  Due to gengtype deficiency the GTY
    options of such types have to agree across all frontends. */
 struct GTY((variable_size))    lang_type        {
-  int rank;
+  int rank, corank;
   enum gfc_array_kind akind;
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -768,6 +768,7 @@ struct GTY((variable_size)) lang_decl {
 #define GFC_TYPE_ARRAY_STRIDE(node, dim) \
   (TYPE_LANG_SPECIFIC(node)->stride[dim])
 #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
+#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
 #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
 #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
 #define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
index 1fa2c642996cd5a7629c700394dcb94b44cb747a..3204df3a820c257a63b01e176ced803bae7f3d90 100644 (file)
@@ -1,3 +1,10 @@
+2011-04-04  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/18918
+       * gfortran.dg/coarray_10.f90: Add coarray descriptor diagnostic check.
+       * gfortran.dg/coarray_13.f90: Add checks for run-time cobounds.
+       * gfortran.dg/coarray_15.f90: New.
+
 2011-04-04  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
        * gfortran.dg/bessel_6.f90: Use dg-add-options ieee.
index 6ee425d7bf98d6bdcec8e1e75cc83505a71669b6..d32e25478c774c98f4237b7568a449ce0b769dd8 100644 (file)
@@ -44,3 +44,9 @@ subroutine rank_mismatch()
   A(1)[1,1] = 1         ! { dg-error "Too few codimensions" }
   A(1)[1,1:1] = 1       ! { dg-error "Too few codimensions" }
 end subroutine rank_mismatch
+
+subroutine rank_mismatch2()
+  implicit none
+  integer, allocatable:: A(:)[:,:,:]
+  allocate(A(1)[7:8,4:*]) ! { dg-error "Unexpected .*. for codimension 2 of 3" }
+end subroutine rank_mismatch2
index bbd1ad49173e7656d6cbf6257b20a6ad18c7f0bc..1c79a079130ad65e3edd9de9ddf6abc8f5d73acd 100644 (file)
 ! { dg-do run }
-! { dg-options "-fcoarray=single" }
+! { dg-options "-fcoarray=single -fcheck=bounds" }
 !
 ! Coarray support -- allocatable array coarrays
+!                 -- intrinsic procedures
 ! PR fortran/18918
 ! PR fortran/43931
 !
 program test
   implicit none
+  integer,allocatable :: B(:)[:]
+
   call one()
+  call two()
+  allocate(B(3)[-4:*])
+  call three(3,B,1)
+  call three_a(3,B)
+  call three_b(3,B)
+  call four(B)
+  call five()
 contains
   subroutine one()
     integer, allocatable :: a(:)[:,:,:]
     allocate(a(1)[-4:9,8,4:*])
+    if (this_image(a,dim=1) /= -4_8) call abort()
+    if (lcobound  (a,dim=1) /= -4_8) call abort()
+    if (ucobound  (a,dim=1) /=  9_8) call abort()
+    if (this_image(a,dim=2) /=  1_8) call abort()
+    if (lcobound  (a,dim=2) /=  1_8) call abort()
+    if (ucobound  (a,dim=2) /=  8_8) call abort()
+    if (this_image(a,dim=3) /= 4_8) call abort()
+    if (lcobound  (a,dim=3) /= 4_8) call abort()
+    if (ucobound  (a,dim=3) /= 4_8) call abort()
+    if (any(this_image(a) /= [-4_8, 1_8, 4_8])) call abort()
+    if (any(lcobound  (a) /= [-4_8, 1_8, 4_8])) call abort()
+    if (any(ucobound  (a) /= [9_8, 8_8, 4_8])) call abort()
   end subroutine one
-  subroutine four(C)
-    integer, allocatable :: C(:)[:]
- end subroutine four
+
+  subroutine two()
+    integer, allocatable :: a(:)[:,:,:]
+    allocate(a(1)[-4:9,8,4:*])
+
+    if (this_image(a,dim=1) /= -4) call abort()
+    if (lcobound  (a,dim=1) /= -4) call abort()
+    if (ucobound  (a,dim=1) /=  9) call abort()
+
+    if (this_image(a,dim=2) /=  1) call abort()
+    if (lcobound  (a,dim=2) /=  1) call abort()
+    if (ucobound  (a,dim=2) /=  8) call abort()
+
+    if (this_image(a,dim=3) /= 4) call abort()
+    if (lcobound  (a,dim=3) /= 4) call abort()
+    if (ucobound  (a,dim=3) /= 4) call abort()
+
+    if (any(this_image(a) /= [-4, 1, 4])) call abort()
+    if (any(lcobound  (a) /= [-4, 1, 4])) call abort()
+    if (any(ucobound  (a) /= [9, 8, 4])) call abort()
+  end subroutine two
+
+  subroutine three(n,A, n2)
+    integer :: n, n2
+    integer :: A(3)[n:*]
+
+    A(1) = 42
+    if (A(1) /= 42) call abort()
+    A(1)[n2] = -42
+    if (A(1)[n2] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n) call abort()
+    if (lcobound  (A,dim=1) /= n) call abort()
+    if (ucobound  (A,dim=1) /= n) call abort()
+
+    if (any(this_image(A) /= n)) call abort()
+    if (any(lcobound  (A) /= n)) call abort()
+    if (any(ucobound  (A) /= n)) call abort()
+  end subroutine three
+
+  subroutine three_a(n,A)
+    integer :: n
+    integer :: A(3)[n+2:n+5,n-1:*]
+
+    A(1) = 42
+    if (A(1) /= 42) call abort()
+    A(1)[4,n] = -42
+    if (A(1)[4,n] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n+2) call abort()
+    if (lcobound  (A,dim=1) /= n+2) call abort()
+    if (ucobound  (A,dim=1) /= n+5) call abort()
+
+    if (this_image(A,dim=2) /= n-1) call abort()
+    if (lcobound  (A,dim=2) /= n-1) call abort()
+    if (ucobound  (A,dim=2) /= n-1) call abort()
+
+    if (any(this_image(A) /= [n+2,n-1])) call abort()
+    if (any(lcobound  (A) /= [n+2,n-1])) call abort()
+    if (any(ucobound  (A) /= [n+5,n-1])) call abort()
+  end subroutine three_a
+
+  subroutine three_b(n,A)
+    integer :: n
+    integer :: A(-1:3,0:4,-2:5,-4:7)[n+2:n+5,n-1:*]
+
+    A(1,1,1,1) = 42
+    if (A(1,1,1,1) /= 42) call abort()
+    A(1,1,1,1)[4,n] = -42
+    if (A(1,1,1,1)[4,n] /= -42) call abort()
+
+    if (this_image(A,dim=1) /= n+2) call abort()
+    if (lcobound  (A,dim=1) /= n+2) call abort()
+    if (ucobound  (A,dim=1) /= n+5) call abort()
+
+    if (this_image(A,dim=2) /= n-1) call abort()
+    if (lcobound  (A,dim=2) /= n-1) call abort()
+    if (ucobound  (A,dim=2) /= n-1) call abort()
+
+    if (any(this_image(A) /= [n+2,n-1])) call abort()
+    if (any(lcobound  (A) /= [n+2,n-1])) call abort()
+    if (any(ucobound  (A) /= [n+5,n-1])) call abort()
+  end subroutine three_b
+
+  subroutine four(A)
+    integer, allocatable :: A(:)[:]
+    if (this_image(A,dim=1) /= -4_8) call abort()
+    if (lcobound  (A,dim=1) /= -4_8) call abort()
+    if (ucobound  (A,dim=1) /= -4_8) call abort()
+  end subroutine four
+
+  subroutine five()
+    integer, save :: foo(2)[5:7,4:*]
+    integer :: i
+
+    i = 1
+    foo(1)[5,4] = 42
+    if (foo(1)[5,4] /= 42) call abort()
+    if (this_image(foo,dim=i) /= 5) call abort()
+    if (lcobound(foo,dim=i) /= 5) call abort()
+    if (ucobound(foo,dim=i) /= 7) call abort()
+
+    i = 2
+    if (this_image(foo,dim=i) /= 4) call abort()
+    if (lcobound(foo,dim=i) /= 4) call abort()
+    if (ucobound(foo,dim=i) /= 4) call abort()
+  end subroutine five
 end program test
diff --git a/gcc/testsuite/gfortran.dg/coarray_15.f90 b/gcc/testsuite/gfortran.dg/coarray_15.f90
new file mode 100644 (file)
index 0000000..91584e2
--- /dev/null
@@ -0,0 +1,112 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Contributed by John Reid.
+!
+program ex2
+      implicit none
+      real, allocatable :: z(:)[:]
+      integer :: image
+      character(len=80) :: str
+
+      allocate(z(3)[*])
+      write(*,*) 'z allocated on image',this_image()
+      sync all
+      if (this_image()==1) then
+          z = 1.2
+          do image = 2, num_images() ! { dg-warning "will be executed zero times" }
+            write(*,*) 'Assigning z(:) on image',image
+            z(:)[image] = z
+         end do
+      end if
+      sync all
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(:),' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z,' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      call ex2a()
+      call ex5()
+end
+
+subroutine ex2a()
+      implicit none
+      real, allocatable :: z(:,:)[:,:]
+      integer :: image
+      character(len=100) :: str
+
+      allocate(z(2,2)[1,*])
+      write(*,*) 'z allocated on image',this_image()
+      sync all
+      if (this_image()==1) then
+          z = 1.2
+          do image = 2, num_images() ! { dg-warning "will be executed zero times" }
+            write(*,*) 'Assigning z(:) on image',image
+            z(:,:)[1,image] = z
+         end do
+      end if
+      sync all
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z(:,:),' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+
+      str = repeat('X', len(str))
+      write(str,*) 'z=',z,' on image',this_image()
+      if (str /= " z=   1.2000000       1.2000000       1.2000000       1.2000000      on image           1") &
+        call abort ()
+end subroutine ex2a
+
+subroutine ex5
+   implicit none
+   integer :: me
+   real, save :: w(4)[*]
+   character(len=100) :: str
+
+   me = this_image()
+   w = me
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w 
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w(1:4) 
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   str = repeat('X', len(str))
+   write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1]
+   if (str /= " In main on image           1 w=    1.0000000       1.0000000       1.0000000       1.0000000") &
+     call abort ()
+
+   sync all
+   call ex5_sub(me,w)
+end subroutine ex5
+      
+subroutine ex5_sub(n,w)
+   implicit none
+   integer :: n
+   real :: w(n)
+   character(len=50) :: str
+
+   str = repeat('X', len(str))
+   write(str,*) 'In sub on image',this_image(), 'w= ',w 
+   if (str /= " In sub on image           1 w=    1.0000000") &
+     call abort ()
+end subroutine ex5_sub