primary.c (gfc_match_varspec): Match array spec for polymorphic coarrays.

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

        * primary.c (gfc_match_varspec): Match array spec for
        polymorphic coarrays.
        (gfc_match_rvalue): If a symbol of unknown flavor has a
        codimension, mark it as a variable.
        * simplify.c (gfc_simplify_image_index): Directly call
        simplify_cobound.
        * trans-intrinsic.c (trans_this_image): Fix handling of
        corank = 1 arrays.

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

        * gfortran.dg/coarray/poly_run_3.f90: New.
        * gfortran.dg/coarray/poly_run_2.f90: Enable comment-out test.

From-SVN: r182371

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 40e01f33f485e9b1a0407abc4fe6e3eb777fe4fa..1f00326faa02e7144943c780defbe32aecfd3f13 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2011-12-15  Tobias Burnus  <burnus@net-b.de>
+
+       * primary.c (gfc_match_varspec): Match array spec for
+       polymorphic coarrays.
+       (gfc_match_rvalue): If a symbol of unknown flavor has a
+       codimension, mark it as a variable.
+       * simplify.c (gfc_simplify_image_index): Directly call
+       simplify_cobound.
+       * trans-intrinsic.c (trans_this_image): Fix handling of
+       corank = 1 arrays.
+
 2011-12-15  Jakub Jelinek  <jakub@redhat.com>
 
        PR debug/51517

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 75c7e137187ad6425ca44a946b21273782064954..afc4684682fd5514523feb9331c735f523514727 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1821,7 +1821,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
          && !(gfc_matching_procptr_assignment
               && sym->attr.flavor == FL_PROCEDURE))
       || (sym->ts.type == BT_CLASS && sym->attr.class_ok
-         && CLASS_DATA (sym)->attr.dimension))
+         && (CLASS_DATA (sym)->attr.dimension
+             || CLASS_DATA (sym)->attr.codimension)))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
         an array, character variable or array of character
@@ -2894,10 +2895,10 @@ gfc_match_rvalue (gfc_expr **result)
          && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
        gfc_set_default_type (sym, 0, sym->ns);
 
-      /* If the symbol has a dimension attribute, the expression is a
+      /* If the symbol has a (co)dimension attribute, the expression is a
         variable.  */
 
-      if (sym->attr.dimension)
+      if (sym->attr.dimension || sym->attr.codimension)
        {
          if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
                              sym->name, NULL) == FAILURE)
@@ -2913,7 +2914,9 @@ gfc_match_rvalue (gfc_expr **result)
          break;
        }
 
-      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+      if (sym->ts.type == BT_CLASS
+         && (CLASS_DATA (sym)->attr.dimension
+             || CLASS_DATA (sym)->attr.codimension))
        {
          if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
                              sym->name, NULL) == FAILURE)

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index e82753abd773b032047b799fc4c4a5891f364e12..282d88d8e4aec9474a800204c6292773d3a3139a 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6227,10 +6227,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
 gfc_expr *
 gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
 {
-  gfc_ref *ref;
-  gfc_array_spec *as;
-  int d;
-
   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
     return NULL;
 
@@ -6244,74 +6240,8 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
       return result;
     }
 
-  gcc_assert (coarray->expr_type == EXPR_VARIABLE);
-
-  /* Follow any component references.  */
-  as = coarray->symtree->n.sym->as;
-  for (ref = coarray->ref; ref; ref = ref->next)
-    if (ref->type == REF_COMPONENT)
-      as = ref->u.ar.as;
-
-  if (as->type == AS_DEFERRED)
-    return NULL;
-
-  if (dim == NULL)
-    {
-      /* Multi-dimensional bounds.  */
-      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
-      gfc_expr *e;
-
-      /* Simplify the bounds for each dimension.  */
-      for (d = 0; d < as->corank; d++)
-       {
-         bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
-                                         as, NULL, true);
-         if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
-           {
-             int j;
-
-             for (j = 0; j < d; j++)
-               gfc_free_expr (bounds[j]);
-
-             return bounds[d];
-           }
-       }
-
-      /* Allocate the result expression.  */
-      e = gfc_get_expr ();
-      e->where = coarray->where;
-      e->expr_type = EXPR_ARRAY;
-      e->ts.type = BT_INTEGER;
-      e->ts.kind = gfc_default_integer_kind;
-
-      e->rank = 1;
-      e->shape = gfc_get_shape (1);
-      mpz_init_set_ui (e->shape[0], as->corank);
-
-      /* Create the constructor for this array.  */
-      for (d = 0; d < as->corank; d++)
-        gfc_constructor_append_expr (&e->value.constructor,
-                                     bounds[d], &e->where);
-
-      return e;
-    }
-  else
-    {
-      /* A DIM argument is specified.  */
-      if (dim->expr_type != EXPR_CONSTANT)
-       return NULL;
-
-      d = mpz_get_si (dim->value.integer);
-
-      if (d < 1 || d > as->corank)
-       {
-         gfc_error ("DIM argument at %L is out of bounds", &dim->where);
-         return &gfc_bad_expr;
-       }
-
-      return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
-                                true);
-   }
+  /* For -fcoarray=single, this_image(A) is the same as lcobound(A).  */
+  return simplify_cobound (coarray, dim, NULL, 0);
 }
 
 

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 58112e37ee9aebe653bb3d197928be9a30b33b54..5c964c1229fe03aece6d91e326f74d3b985bb33d 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1054,6 +1054,11 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
      one always has a dim_arg argument.
 
      m = this_images() - 1
+     if (corank == 1)
+       {
+        sub(1) = m + lcobound(corank)
+        return;
+       }
      i = rank
      min_var = min (rank + corank - 2, rank + dim_arg - 1)
      for (;;)
@@ -1070,15 +1075,29 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
                                       : m + lcobound(corank)
   */
 
+  /* this_image () - 1.  */
+  tmp = fold_convert (type, gfort_gvar_caf_this_image);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+                      build_int_cst (type, 1));
+  if (corank == 1)
+    {
+      /* sub(1) = m + lcobound(corank).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc,
+                       build_int_cst (TREE_TYPE (gfc_array_index_type),
+                                      corank+rank-1));
+      lbound = fold_convert (type, lbound);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+      se->expr = tmp;
+      return;
+    }
+
   m = gfc_create_var (type, NULL); 
   ml = gfc_create_var (type, NULL); 
   loop_var = gfc_create_var (integer_type_node, NULL); 
   min_var = gfc_create_var (integer_type_node, NULL); 
 
   /* m = this_image () - 1.  */
-  tmp = fold_convert (type, gfort_gvar_caf_this_image);
-  tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
-                      build_int_cst (type, 1));
   gfc_add_modify (&se->pre, m, tmp);
 
   /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 212e455c6e662174c248c323c81e9a9071226c3a..465097785cdc4b36a35a9eba22b1c4374a56eac4 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2011-12-15  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/coarray/poly_run_3.f90: New.
+       * gfortran.dg/coarray/poly_run_2.f90: Enable comment-out test.
+
 2011-12-15  Richard Guenther  <rguenther@suse.de>
 
        PR lto/51564

diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
index fe524a0751a2fc95e5f618478fa35110d11cf5be..02704dd7796069c1e03450e0842e726d6d6690cf 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
@@ -10,9 +10,8 @@ if (allocated(A)) stop
 if (any (lcobound(A) /= [1, -5])) call abort ()
 if (num_images() == 1) then
   if (any (ucobound(A) /= [4, -5])) call abort ()
-! FIXME: Tree walk issue
-!else
-!  if (ucobound(A,dim=1) /= 4) call abort ()
+else
+  if (ucobound(A,dim=1) /= 4) call abort ()
 end if
 if (allocated(A)) i = 5
 call s(A)

diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90
new file mode 100644 (file)
index 0000000..17a0108
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! Check that the bounds of polymorphic coarrays is
+! properly handled.
+!
+type t
+end type t
+class(t), allocatable :: a(:)[:]
+class(t), allocatable :: b[:], d[:]
+
+allocate(a(1)[*])
+if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
+  call abort ()
+if (any (lcobound(a) /= 1)) call abort()
+if (any (ucobound(a) /= this_image())) call abort ()
+deallocate(a)
+
+allocate(b[*])
+if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
+  call abort ()
+if (any (lcobound(b) /= 1)) call abort()
+if (any (ucobound(b) /= this_image())) call abort ()
+deallocate(b)
+
+allocate(a(1)[-10:*])
+if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
+  call abort ()
+if (any (lcobound(a) /= -10)) call abort()
+if (any (ucobound(a) /= -11+this_image())) call abort ()
+deallocate(a)
+
+allocate(d[23:*])
+if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
+  call abort ()
+if (any (lcobound(d) /= 23)) call abort()
+if (any (ucobound(d) /= 22+this_image())) call abort ()
+deallocate(d)
+
+end