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

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

        PR fortran/18918
        * array.c (gfc_free_array_spec,gfc_resolve_array_spec,
        match_array_element_spec,gfc_copy_array_spec,
        gfc_compare_array_spec): Include corank.
        (match_array_element_spec,gfc_set_array_spec): Support codimension.
        * decl.c (build_sym,build_struct,variable_decl,
        match_attr_spec,attr_decl1,cray_pointer_decl,
        gfc_match_volatile): Add codimension.
        (gfc_match_codimension): New function.
        * dump-parse-tree.c (show_array_spec,show_attr): Support
        * codimension.
        * gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
        (gfc_add_codimension): New function prototype.
        * match.h (gfc_match_codimension): New function prototype.
        (gfc_match_array_spec): Update prototype
        * match.c (gfc_match_common): Update gfc_match_array_spec call.
        * module.c (MOD_VERSION): Bump.
        (mio_symbol_attribute): Support coarray attributes.
        (mio_array_spec): Add corank support.
        * parse.c (decode_specification_statement,decode_statement,
        parse_derived): Add coarray support.
        * resolve.c (resolve_formal_arglist, was_declared,
        is_non_constant_shape_array, resolve_fl_variable,
        resolve_fl_derived, resolve_symbol): Add coarray support.
        * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
        gfc_build_class_symbol): Add coarray support.
        (gfc_add_codimension): New function.

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

        PR fortran/18918
        * gfortran.dg/coarray_4.f90: New test.
        * gfortran.dg/coarray_5.f90: New test.
        * gfortran.dg/coarray_6.f90: New test.

From-SVN: r158012

1 files changed, 213 insertions, 22 deletions

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index e0714e3..4b2ccf6 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -188,7 +188,7 @@ gfc_free_array_spec (gfc_array_spec *as)
   if (as == NULL)
     return;
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       gfc_free_expr (as->lower[i]);
       gfc_free_expr (as->upper[i]);
@@ -234,7 +234,7 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
   if (as == NULL)
     return SUCCESS;
 
-  for (i = 0; i < as->rank; i++)
+  for (i = 0; i < as->rank + as->corank; i++)
     {
       e = as->lower[i];
       if (resolve_array_bound (e, check_constant) == FAILURE)
@@ -290,8 +290,8 @@ match_array_element_spec (gfc_array_spec *as)
   gfc_expr **upper, **lower;
   match m;
 
-  lower = &as->lower[as->rank - 1];
-  upper = &as->upper[as->rank - 1];
+  lower = &as->lower[as->rank + as->corank - 1];
+  upper = &as->upper[as->rank + as->corank - 1];
 
   if (gfc_match_char ('*') == MATCH_YES)
     {
@@ -335,22 +335,20 @@ match_array_element_spec (gfc_array_spec *as)
 
 
 /* Matches an array specification, incidentally figuring out what sort
-   it is.  */
+   it is. Match either a normal array specification, or a coarray spec
+   or both. Optionally allow [:] for coarrays.  */
 
 match
-gfc_match_array_spec (gfc_array_spec **asp)
+gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
 {
   array_type current_type;
+  array_type coarray_type = AS_UNKNOWN;
   gfc_array_spec *as;
   int i;
-
-  if (gfc_match_char ('(') != MATCH_YES)
-    {
-      *asp = NULL;
-      return MATCH_NO;
-    }
-
+ 
   as = gfc_get_array_spec ();
+  as->corank = 0;
+  as->rank = 0;
 
   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
     {
@@ -358,10 +356,19 @@ gfc_match_array_spec (gfc_array_spec **asp)
       as->upper[i] = NULL;
     }
 
-  as->rank = 1;
+  if (!match_dim)
+    goto coarray;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
 
   for (;;)
     {
+      as->rank++;
       current_type = match_array_element_spec (as);
 
       if (as->rank == 1)
@@ -427,32 +434,150 @@ gfc_match_array_spec (gfc_array_spec **asp)
 	  goto cleanup;
 	}
 
-      if (as->rank >= GFC_MAX_DIMENSIONS)
+      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
 	{
 	  gfc_error ("Array specification at %C has more than %d dimensions",
 		     GFC_MAX_DIMENSIONS);
 	  goto cleanup;
 	}
 
-      if (as->rank >= 7
+      if (as->corank + as->rank >= 7
 	  && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
 			     "specification at %C with more than 7 dimensions")
 	     == FAILURE)
 	goto cleanup;
+    }
 
-      as->rank++;
+  if (!match_codim)
+    goto done;
+
+coarray:
+  if (gfc_match_char ('[')  != MATCH_YES)
+    goto done;
+
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
+      == FAILURE)
+    goto cleanup;
+
+  for (;;)
+    {
+      as->corank++;
+      current_type = match_array_element_spec (as);
+
+      if (current_type == AS_UNKNOWN)
+	goto cleanup;
+
+      if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED)
+	{
+	  gfc_error ("Array at %C has non-deferred shape and deferred "
+		     "coshape");
+          goto cleanup;
+	}
+      if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED)
+	{
+	  gfc_error ("Array at %C has deferred shape and non-deferred "
+		     "coshape");
+          goto cleanup;
+	}
+
+      if (as->corank == 1)
+	coarray_type = current_type;
+      else
+	switch (coarray_type)
+	  { /* See how current spec meshes with the existing.  */
+	    case AS_UNKNOWN:
+	      goto cleanup;
+
+	    case AS_EXPLICIT:
+	      if (current_type == AS_ASSUMED_SIZE)
+		{
+		  coarray_type = AS_ASSUMED_SIZE;
+		  break;
+		}
+
+	      if (current_type == AS_EXPLICIT)
+		break;
+
+	      gfc_error ("Bad array specification for an explicitly "
+			 "shaped array at %C");
+
+	      goto cleanup;
+
+	    case AS_ASSUMED_SHAPE:
+	      if ((current_type == AS_ASSUMED_SHAPE)
+		  || (current_type == AS_DEFERRED))
+		break;
+
+	      gfc_error ("Bad array specification for assumed shape "
+			 "array at %C");
+	      goto cleanup;
+
+	    case AS_DEFERRED:
+	      if (current_type == AS_DEFERRED)
+		break;
+
+	      if (current_type == AS_ASSUMED_SHAPE)
+		{
+		  as->type = AS_ASSUMED_SHAPE;
+		  break;
+		}
+
+	      gfc_error ("Bad specification for deferred shape array at %C");
+	      goto cleanup;
+
+	    case AS_ASSUMED_SIZE:
+	      gfc_error ("Bad specification for assumed size array at %C");
+	      goto cleanup;
+	  }
+
+      if (gfc_match_char (']') == MATCH_YES)
+	break;
+
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected another dimension in array declaration at %C");
+	  goto cleanup;
+	}
+
+      if (as->corank >= GFC_MAX_DIMENSIONS)
+	{
+	  gfc_error ("Array specification at %C has more than %d "
+		     "dimensions", GFC_MAX_DIMENSIONS);
+	  goto cleanup;
+	}
+    }
+
+  if (current_type == AS_EXPLICIT)
+    {
+      gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
+      goto cleanup;
+    }
+
+  if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
+    as->type = AS_EXPLICIT;
+  else if (as->rank == 0)
+    as->type = coarray_type;
+
+done:
+  if (as->rank == 0 && as->corank == 0)
+    {
+      *asp = NULL;
+      gfc_free_array_spec (as);
+      return MATCH_NO;
     }
 
   /* If a lower bounds of an assumed shape array is blank, put in one.  */
   if (as->type == AS_ASSUMED_SHAPE)
     {
-      for (i = 0; i < as->rank; i++)
+      for (i = 0; i < as->rank + as->corank; i++)
 	{
 	  if (as->lower[i] == NULL)
 	    as->lower[i] = gfc_int_expr (1);
 	}
     }
+
   *asp = as;
+
   return MATCH_YES;
 
 cleanup:
@@ -469,14 +594,77 @@ cleanup:
 gfc_try
 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
 {
+  int i;
+
   if (as == NULL)
     return SUCCESS;
 
-  if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
+  if (as->rank
+      && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
     return FAILURE;
 
-  sym->as = as;
+  if (as->corank
+      && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
+    return FAILURE;
+
+  if (sym->as == NULL)
+    {
+      sym->as = as;
+      return SUCCESS;
+    }
+
+  if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has deferred shape and non-deferred coshape",
+		 sym->name, error_loc);
+      return FAILURE;
+    }
+
+  if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED)
+    {
+      gfc_error ("'%s' at %L has non-deferred shape and deferred coshape",
+		 sym->name, error_loc);
+      return FAILURE;
+    }
+
+  if (as->corank)
+    {
+      /* The "sym" has no corank (checked via gfc_add_codimension). Thus
+	 the codimension is simply added.  */
+      gcc_assert (as->rank == 0 && sym->as->corank == 0);
+
+      sym->as->corank = as->corank;
+      for (i = 0; i < as->corank; i++)
+	{
+	  sym->as->lower[sym->as->rank + i] = as->lower[i];
+	  sym->as->upper[sym->as->rank + i] = as->upper[i];
+	}
+    }
+  else
+    {
+      /* The "sym" has no rank (checked via gfc_add_dimension). Thus
+	 the dimension is added - but first the codimensions (if existing
+	 need to be shifted to make space for the dimension.  */
+      gcc_assert (as->corank == 0 && sym->as->rank == 0);
+
+      sym->as->rank = as->rank;
+      sym->as->type = as->type;
+      sym->as->cray_pointee = as->cray_pointee;
+      sym->as->cp_was_assumed = as->cp_was_assumed;
+
+      for (i = 0; i < sym->as->corank; i++)
+	{
+	  sym->as->lower[as->rank + i] = sym->as->lower[i];
+	  sym->as->upper[as->rank + i] = sym->as->upper[i];
+	}
+      for (i = 0; i < as->rank; i++)
+	{
+	  sym->as->lower[i] = as->lower[i];
+	  sym->as->upper[i] = as->upper[i];
+	}
+    }
 
+  gfc_free (as);
   return SUCCESS;
 }
 
@@ -496,7 +684,7 @@ gfc_copy_array_spec (gfc_array_spec *src)
 
   *dest = *src;
 
-  for (i = 0; i < dest->rank; i++)
+  for (i = 0; i < dest->rank + dest->corank; i++)
     {
       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
@@ -543,6 +731,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
   if (as1->rank != as2->rank)
     return 0;
 
+  if (as1->corank != as2->corank)
+    return 0;
+
   if (as1->rank == 0)
     return 1;
 
@@ -550,7 +741,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
     return 0;
 
   if (as1->type == AS_EXPLICIT)
-    for (i = 0; i < as1->rank; i++)
+    for (i = 0; i < as1->rank + as1->corank; i++)
       {
 	if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
 	  return 0;