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

gcc/fortran/ChangeLog

+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

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)

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);
 }
 
 

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).  */

gcc/testsuite/ChangeLog

+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

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)

gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90

+! { 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