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

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

        PR fortran/18918
        * resolve.c (resolve_allocate_expr): Allow array coarrays.
        * trans-types.h (gfc_get_array_type_bounds): Update prototype.
        * trans-types.c (gfc_get_array_type_bounds,
        gfc_get_array_descriptor_base): Add corank argument.
        * trans-array.c (gfc_array_init_size): Handle corank.
        (gfc_trans_create_temp_array, gfc_array_allocate,
        gfc_conv_expr_descriptor): Add corank argument to call.
        * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.

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

        PR fortran/18918
        * gfortran.dg/coarray_7.f90: Modified and removed obsolete
        tests.
        * gfortran.dg/coarray_12.f90: New.

From-SVN: r158768

gcc/fortran/ChangeLog

+2010-04-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* resolve.c (resolve_allocate_expr): Allow array coarrays.
+	* trans-types.h (gfc_get_array_type_bounds): Update prototype.
+	* trans-types.c (gfc_get_array_type_bounds,
+	gfc_get_array_descriptor_base): Add corank argument.
+	* trans-array.c (gfc_array_init_size): Handle corank.
+	(gfc_trans_create_temp_array, gfc_array_allocate,
+	gfc_conv_expr_descriptor): Add corank argument to call.
+	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.
+
 2010-04-24  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/30073

gcc/fortran/resolve.c

@@ -6561,9 +6561,9 @@ check_symbols:
       goto failure;
     }
 
-  if (codimension)
+  if (codimension && ar->as->rank == 0)
     {
-      gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+      gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
 		 "at %L", &e->where);
       goto failure;
     }

gcc/fortran/trans-array.c

@@ -725,7 +725,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 
   /* Initialize the descriptor.  */
   type =
-    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+    gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
 			       GFC_ARRAY_UNKNOWN, true);
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
@@ -3819,7 +3819,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
 /*GCC ARRAYS*/
 
 static tree
-gfc_array_init_size (tree descriptor, int rank, tree * poffset,
+gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper,
 		     stmtblock_t * pblock)
 {
@@ -3917,6 +3917,43 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset,
       stride = gfc_evaluate_now (stride, pblock);
     }
 
+  for (n = rank; n < rank + corank; n++)
+    {
+      ubound = upper[n];
+
+      /* Set lower bound.  */
+      gfc_init_se (&se, NULL);
+      if (lower == NULL || lower[n] == NULL)
+	{
+	  gcc_assert (n == rank + corank - 1);
+	  se.expr = gfc_index_one_node;
+	}
+      else
+	{
+          if (ubound || n == rank + corank - 1)
+            {
+	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+	      gfc_add_block_to_block (pblock, &se.pre);
+            }
+          else
+            {
+              se.expr = gfc_index_one_node;
+              ubound = lower[n];
+            }
+	}
+      gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
+				      se.expr);
+
+      if (n < rank + corank - 1)
+	{
+	  gfc_init_se (&se, NULL);
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
+	}
+    }
+
   /* The stride is the number of elements in the array, so multiply by the
      size of an element to get the total size.  */
   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -3965,7 +4002,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   gfc_expr **lower;
   gfc_expr **upper;
   gfc_ref *ref, *prev_ref = NULL;
-  bool allocatable_array;
+  bool allocatable_array, coarray;
 
   ref = expr->ref;
 
@@ -3981,29 +4018,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
   if (ref == NULL || ref->type != REF_ARRAY)
     return false;
 
-  /* Return if this is a scalar coarray.  */
-  if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+  if (!prev_ref)
     {
-      gcc_assert (expr->symtree->n.sym->attr.codimension);
-      return false;
+      allocatable_array = expr->symtree->n.sym->attr.allocatable;
+      coarray = expr->symtree->n.sym->attr.codimension;
     }
-  else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+  else
     {
-      gcc_assert (prev_ref->u.c.component->attr.codimension);
-      return false;
+      allocatable_array = prev_ref->u.c.component->attr.allocatable;
+      coarray = prev_ref->u.c.component->attr.codimension;
     }
 
-  if (!prev_ref)
-    allocatable_array = expr->symtree->n.sym->attr.allocatable;
-  else
-    allocatable_array = prev_ref->u.c.component->attr.allocatable;
+  /* Return if this is a scalar coarray.  */
+  if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
+      || (prev_ref && !prev_ref->u.c.component->attr.dimension))
+    {
+      gcc_assert (coarray);
+      return false;
+    }
 
   /* Figure out the size of the array.  */
   switch (ref->u.ar.type)
     {
     case AR_ELEMENT:
-      lower = NULL;
-      upper = ref->u.ar.start;
+      if (!coarray)
+	{
+	  lower = NULL;
+	  upper = ref->u.ar.start;
+	  break;
+	}
+      /* Fall through.  */
+
+    case AR_SECTION:
+      lower = ref->u.ar.start;
+      upper = ref->u.ar.end;
       break;
 
     case AR_FULL:
@@ -4013,18 +4061,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
       upper = ref->u.ar.as->upper;
       break;
 
-    case AR_SECTION:
-      lower = ref->u.ar.start;
-      upper = ref->u.ar.end;
-      break;
-
     default:
       gcc_unreachable ();
       break;
     }
 
-  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
-			      lower, upper, &se->pre);
+  size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+			      ref->u.ar.as->corank, &offset, lower, upper,
+			      &se->pre);
 
   /* Allocate memory to store the data.  */
   pointer = gfc_conv_descriptor_data_get (se->expr);
@@ -5299,7 +5343,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	{
 	  /* Otherwise make a new one.  */
 	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
-	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
 						loop.from, loop.to, 0,
 						GFC_ARRAY_UNKNOWN, false);
 	  parm = gfc_create_var (parmtype, "parm");

gcc/fortran/trans-stmt.c

@@ -2822,7 +2822,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
 
       /* Make a new descriptor.  */
       parmtype = gfc_get_element_type (TREE_TYPE (desc));
-      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+      parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
                                             loop.from, loop.to, 1,
 					    GFC_ARRAY_UNKNOWN, true);
 

gcc/fortran/trans-types.c

@@ -1222,8 +1222,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
 
   if (as->type == AS_ASSUMED_SHAPE)
     akind = GFC_ARRAY_ASSUMED_SHAPE;
-  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind,
-				    restricted);
+  return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+				    ubound, 0, akind, restricted);
 }
 
 /* Returns the struct descriptor_dimension type.  */
@@ -1538,20 +1538,21 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
 /* Return or create the base type for an array descriptor.  */
 
 static tree
-gfc_get_array_descriptor_base (int dimen, bool restricted)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
 {
   tree fat_type, fieldlist, decl, arraytype;
-  char name[16 + GFC_RANK_DIGITS + 1];
+  char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
   int idx = 2 * (dimen - 1) + restricted;
 
-  gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
+  gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
   if (gfc_array_descriptor_base[idx])
     return gfc_array_descriptor_base[idx];
 
   /* Build the type node.  */
   fat_type = make_node (RECORD_TYPE);
 
-  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
+  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT "_"
+	   GFC_RANK_PRINTF_FORMAT, dimen, codimen);
   TYPE_NAME (fat_type) = get_identifier (name);
 
   /* Add the data member as the first element of the descriptor.  */
@@ -1583,7 +1584,7 @@ gfc_get_array_descriptor_base (int dimen, bool restricted)
     build_array_type (gfc_get_desc_dim_type (),
 		      build_range_type (gfc_array_index_type,
 					gfc_index_zero_node,
-					gfc_rank_cst[dimen - 1]));
+					gfc_rank_cst[codimen + dimen - 1]));
 
   decl = build_decl (input_location,
 		     FIELD_DECL, get_identifier ("dim"), arraytype);
@@ -1604,20 +1605,20 @@ gfc_get_array_descriptor_base (int dimen, bool restricted)
 /* Build an array (descriptor) type with given bounds.  */
 
 tree
-gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
+gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
 			   tree * ubound, int packed,
 			   enum gfc_array_kind akind, bool restricted)
 {
-  char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
+  char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
   tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
   const char *type_name;
   int n;
 
-  base_type = gfc_get_array_descriptor_base (dimen, restricted);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
   fat_type = build_distinct_type_copy (base_type);
   /* Make sure that nontarget and target array type have the same canonical
      type (and same stub decl for debug info).  */
-  base_type = gfc_get_array_descriptor_base (dimen, false);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
   TYPE_CANONICAL (fat_type) = base_type;
   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
 
@@ -1628,7 +1629,8 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
     type_name = IDENTIFIER_POINTER (tmp);
   else
     type_name = "unknown";
-  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
+  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_"
+	   GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, codimen,
 	   GFC_MAX_SYMBOL_LEN, type_name);
   TYPE_NAME (fat_type) = get_identifier (name);
 

gcc/fortran/trans-types.h

@@ -72,7 +72,7 @@ tree gfc_type_for_mode (enum machine_mode, int);
 tree gfc_build_uint_type (int);
 
 tree gfc_get_element_type (tree);
-tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
+tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
 				enum gfc_array_kind, bool);
 tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
 

gcc/testsuite/ChangeLog

+2010-04-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_7.f90: Modified and removed obsolete tests.
+	* gfortran.dg/coarray_12.f90: New.
+
 2010-04-27  Shujing Zhao  <pearly.zhao@oracle.com>
 
 	PR c/32207

gcc/testsuite/gfortran.dg/coarray_12.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single -fdump-tree-original" }
+!
+! Coarray support -- allocatable array coarrays
+! PR fortran/18918
+!
+integer,allocatable :: a(:)[:,:]
+nn = 5
+mm = 7
+allocate(a(nn)[mm,*])
+end
+
+subroutine testAlloc3
+  implicit none
+  integer, allocatable :: ab(:,:,:)[:,:]
+  integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
+  integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
+  integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
+  integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
+  integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
+
+  allocate(ab(1,2,3)[4,*])
+  allocate(b(1,2,3)[4,*])
+  allocate(c(1,2)[3,4,*])
+  allocate(d(1,2)[3,*])
+  allocate(e(1,2)[3,4,*])
+  allocate(f(1,2)[3,*])
+end subroutine testAlloc3
+
+subroutine testAlloc4()
+  implicit none
+  integer, allocatable :: xxx(:)[:,:,:,:]
+  integer :: mmm
+  mmm=88
+  allocate(xxx(1)[7,-5:8,mmm:2,*])
+end subroutine testAlloc4
+
+subroutine testAlloc5()
+  implicit none
+  integer, allocatable :: yyy(:)[:,:,:,:]
+  integer :: ooo, ppp
+  ooo=88
+  ppp=42
+  allocate(yyy(1)[7,-5:ppp,1,ooo:*])
+end subroutine testAlloc5
+
+
+! { dg-final { scan-tree-dump-times "a.dim.0..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.0..ubound = .* nn;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.1..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.1..ubound = .* mm;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.2..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.2..ubound"          0 "original" } }
+
+! { dg-final { scan-tree-dump-times "xxx.dim.0..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.0..ubound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.1..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.1..ubound = 7;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.2..lbound = -5;"    1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.2..ubound = 8;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.3..lbound = .*mmm;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.3..ubound = 2;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.4..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.4..ubound"          0 "original" } }
+
+! { dg-final { scan-tree-dump-times "yyy.dim.0..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.0..ubound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.1..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.1..ubound = 7;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.2..lbound = -5;"    1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.2..ubound = .*ppp;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.3..lbound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.3..ubound = 1;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.4..lbound = .*ooo;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.4..ubound"          0 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_7.f90

@@ -91,7 +91,6 @@ type(t), allocatable :: b(:)[:], C[:]
 allocate(b(1)) ! { dg-error "Coarray specification" }
 allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" }
 allocate(c[*]) ! { dg-error "Sorry" }
-allocate(b(3)[5:*]) ! { dg-error "Sorry" }
 allocate(a%a(5)) ! OK
 end subroutine alloc
 
@@ -148,34 +147,16 @@ end subroutine test4
 
 subroutine allocateTest()
   implicit none
-  real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c
+  real, allocatable, codimension[:,:] :: a,b,c
   integer :: n, q
   n = 1
   q = 1
-  allocate(a(n,n)[q,*]) ! { dg-error "Sorry" }
-  allocate(b(n,n)[q,*]) ! { dg-error "Sorry" }
-  allocate(c(n,n)[q,*]) ! { dg-error "Sorry" }
+  allocate(a[q,*]) ! { dg-error "Sorry" }
+  allocate(b[q,*]) ! { dg-error "Sorry" }
+  allocate(c[q,*]) ! { dg-error "Sorry" }
 end subroutine allocateTest
 
 
-subroutine testAlloc3
-implicit none
-integer, allocatable :: a(:,:,:)[:,:]
-integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
-integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
-integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
-integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
-integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
-
-allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" }
-allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" }
-allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" }
-allocate(d(1,2)[3,*])   ! { dg-error "Sorry" }
-allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" }
-allocate(f(1,2)[3,*]) ! { dg-error "Sorry" }
-end subroutine testAlloc3
-
-
 subroutine testAlloc4()
   implicit none
   type co_double_3