re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

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

        PR fortran/18918
        * array.c (gfc_find_array_ref): Handle codimensions.
        (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error.
        * check.c (is_coarray, dim_corank_check, gfc_check_lcobound,
        gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound):
        New functions.
        * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX,
        GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE,
        GFC_ISYM_UCOBOUND.
        * intrinsic.h (add_functions): Add this_image, image_index,
        lcobound and ucobound intrinsics.
        * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound,
        gfc_check_image_index, gfc_check_this_image,
        gfc_simplify_image_index, gfc_simplify_lcobound,
        gfc_simplify_this_image, gfc_simplify_ucobound):
        New function prototypes.
        * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE
        IMAGE_INDEX): Document new intrinsic functions.
        * match.c (gfc_match_critical, sync_statement): Make
        * -fcoarray=none
        error fatal.
        * simplify.c (simplify_bound_dim): Handle coarrays.
        (simplify_bound): Update simplify_bound_dim call.
        (gfc_simplify_num_images): Add -fcoarray=none check.
        (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound,
        gfc_simplify_ucobound, gfc_simplify_ucobound): New functions.

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

        PR fortran/18918
        * gfortran.dg/coarray_9.f90: Update dg-errors.
        * gfortran.dg/coarray_10.f90: New test.
        * gfortran.dg/coarray_11.f90: New test.

From-SVN: r158292

1 files changed, 392 insertions, 6 deletions

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index b909b1c..1838c00 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2722,13 +2722,14 @@ gfc_simplify_kind (gfc_expr *e)
 
 static gfc_expr *
 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
-		    gfc_array_spec *as, gfc_ref *ref)
+		    gfc_array_spec *as, gfc_ref *ref, bool coarray)
 {
   gfc_expr *l, *u, *result;
   int k;
 
   /* The last dimension of an assumed-size array is special.  */
-  if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+  if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+      || (coarray && d == as->rank + as->corank))
     {
       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
 	return gfc_copy_expr (as->lower[d-1]);
@@ -2745,12 +2746,13 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 
 
   /* Then, we need to know the extent of the given dimension.  */
-  if (ref->u.ar.type == AR_FULL)
+  if (coarray || ref->u.ar.type == AR_FULL)
     {
       l = as->lower[d-1];
       u = as->upper[d-1];
 
-      if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
+      if (l->expr_type != EXPR_CONSTANT || u == NULL
+	  || u->expr_type != EXPR_CONSTANT)
 	return NULL;
 
       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
@@ -2861,7 +2863,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
       /* Simplify the bounds for each dimension.  */
       for (d = 0; d < array->rank; d++)
 	{
-	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
+					  false);
 	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
 	    {
 	      int j;
@@ -2908,7 +2911,131 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  return &gfc_bad_expr;
 	}
 
-      return simplify_bound_dim (array, kind, d, upper, as, ref);
+      return simplify_bound_dim (array, kind, d, upper, as, ref, false);
+    }
+}
+
+
+static gfc_expr *
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (array->expr_type != EXPR_VARIABLE)
+    return NULL;
+
+  /* Follow any component references.  */
+  as = array->symtree->n.sym->as;
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      if (!ref->next)
+	        goto done;
+
+	    /* Fall through.  */
+
+	    case AR_UNKNOWN:
+	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	  continue;
+	}
+    }
+
+  gcc_unreachable ();
+
+ done:
+
+  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+    return NULL;
+
+  if (dim == NULL)
+    {
+      /* Multi-dimensional cobounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      int k;
+
+      /* Simplify the cobounds for each dimension.  */
+      for (d = 0; d < as->corank; d++)
+	{
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+					  upper, as, ref, 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 = array->where;
+      e->expr_type = EXPR_ARRAY;
+      e->ts.type = BT_INTEGER;
+      k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
+		    gfc_default_integer_kind); 
+      if (k == -1)
+	{
+	  gfc_free_expr (e);
+	  return &gfc_bad_expr;
+	}
+      e->ts.kind = k;
+
+      /* The result is a rank 1 array; its size is the rank of the first
+	 argument to {L,U}COBOUND.  */
+      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 (array, kind, d+array->rank, upper, as, ref, true);
     }
 }
 
@@ -2921,6 +3048,21 @@ 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;
+}
+
+gfc_expr *
 gfc_simplify_leadz (gfc_expr *e)
 {
   unsigned long lz, bs;
@@ -3703,6 +3845,13 @@ gfc_expr *
 gfc_simplify_num_images (void)
 {
   gfc_expr *result;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return &gfc_bad_expr;
+    }
+
   /* FIXME: gfc_current_locus is wrong.  */
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
@@ -5174,11 +5323,248 @@ gfc_simplify_trim (gfc_expr *e)
 
 
 gfc_expr *
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+  gfc_expr *result;
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  gfc_constructor *sub_cons;
+  bool first_image;
+  int d;
+
+  if (!is_constant_array_expr (sub))
+    goto not_implemented; /* return NULL;*/
+
+  /* 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)
+    goto not_implemented; /* return NULL;*/
+
+  /* "valid sequence of cosubscripts" are required; thus, return 0 unless
+     the cosubscript addresses the first image.  */
+
+  sub_cons = gfc_constructor_first (sub->value.constructor);
+  first_image = true;
+
+  for (d = 1; d <= as->corank; d++)
+    {
+      gfc_expr *ca_bound;
+      int cmp;
+
+      if (sub_cons == NULL)
+	{
+	  gfc_error ("Too few elements in expression for SUB= argument at %L",
+		     &sub->where);
+	  return &gfc_bad_expr;
+	}
+
+      ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+				     NULL, true);
+      if (ca_bound == NULL)
+	goto not_implemented; /* return NULL */
+
+      if (ca_bound == &gfc_bad_expr)
+	return ca_bound;
+
+      cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
+
+      if (cmp == 0)
+	{
+          gfc_free_expr (ca_bound);
+	  sub_cons = gfc_constructor_next (sub_cons);
+	  continue;
+	}
+
+      first_image = false;
+
+      if (cmp > 0)
+	{
+	  gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		     "SUB has %ld and COARRAY lower bound is %ld)",
+		     &coarray->where, d,
+		     mpz_get_si (sub_cons->expr->value.integer),
+		     mpz_get_si (ca_bound->value.integer));
+	  gfc_free_expr (ca_bound);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_free_expr (ca_bound);
+
+      /* Check whether upperbound is valid for the multi-images case.  */
+      if (d < as->corank)
+	{
+	  ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
+					 NULL, true);
+	  if (ca_bound == &gfc_bad_expr)
+	    return ca_bound;
+
+	  if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
+	      && mpz_cmp (ca_bound->value.integer,
+			  sub_cons->expr->value.integer) < 0)
+	  {
+	    gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		       "SUB has %ld and COARRAY upper bound is %ld)",
+		       &coarray->where, d,
+		       mpz_get_si (sub_cons->expr->value.integer),
+		       mpz_get_si (ca_bound->value.integer));
+	    gfc_free_expr (ca_bound);
+	    return &gfc_bad_expr;
+	  }
+
+	  if (ca_bound)
+	    gfc_free_expr (ca_bound);
+	}
+
+      sub_cons = gfc_constructor_next (sub_cons);
+    }
+
+  if (sub_cons != NULL)
+    {
+      gfc_error ("Too many elements in expression for SUB= argument at %L",
+		 &sub->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				  &gfc_current_locus);
+  if (first_image)
+    mpz_set_si (result->value.integer, 1);
+  else
+    mpz_set_si (result->value.integer, 0);
+
+  return result;
+
+not_implemented:
+  gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
+	     "cobounds at %L", &coarray->where);
+  return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (coarray == NULL)
+    {
+      gfc_expr *result;
+      /* FIXME: gfc_current_locus is wrong.  */
+      result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+				      &gfc_current_locus);
+      mpz_set_si (result->value.integer, 1);
+      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)
+    goto not_implemented; /* 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]);
+	      if (bounds[d] == NULL)
+		goto not_implemented;
+	      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
+    {
+      gfc_expr *e;
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+	goto not_implemented; /*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);*/
+      e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
+      if (e != NULL)
+	return e;
+      else
+	goto not_implemented;
+   }
+
+not_implemented:
+  gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
+	     "cobounds at %L", &coarray->where);
+  return &gfc_bad_expr;
+}
+
+
+gfc_expr *
 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   return simplify_bound (array, dim, kind, 1);
 }
 
+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;
+}
+
 
 gfc_expr *
 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)