[Patch, Fortran] Some fixes for polymorphic coarrays

[Tobias Burnus <burnus at net-b dot de>]

Two small fixes:

a) There was an ICE when simplifying "THIS_IMAGE(caf)" (for 
-fcoarray=single); solution: Simply use internally lcobound(), which is 
identically (for a single image).

b) There was an segfault of the compiled program when running 
"this_image(caf)" where "caf" is a corank-1 coarray. Calculating the 
extend of an assumed size array should be avoided ...

The patch has been build and regtested on x86-64-linux.
OK for the trunk?

Tobias

PS: There are still some other issues with polymorphic coarrays, see 
"Next steps" in 
http://users.physik.fu-berlin.de/~tburnus/coarray/README.txt for a list. 
For instance, there is an ICE if one tries to explicitly deallocate 
scalar polymorphic coarrays.
2011-12-13  Tobias Burnus  <burnus@net-b.de>

	* simplify.c (gfc_simplify_image_index): Directly call
	simplify_cobound.
	* trans-intrinsic.c (trans_this_image): Fix handling of
	corank = 1 arrays.

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

	* gfortran.dg/coarray/poly_run_3.f90: New.

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index e82753a..282d88d 100644
--- 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 58112e3..5c964c1 100644
--- 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).  */
--- /dev/null	2011-12-13 13:39:04.395699646 +0100
+++ gcc/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90	2011-12-13 17:00:44.000000000 +0100
@@ -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) ! FIXME
+
+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) ! FIXME
+
+end