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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158768 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a45ba4f..9db6b60 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 43c53eb..12c694a 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6604,9 +6604,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;
     }

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 2338619..e20406c 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1308,13 +1308,14 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
          else
            {
              /* Collect multiple scalar constants into a constructor.  */
-             VEC(constructor_elt,gc) *v = NULL;
+             tree list;
              tree init;
              tree bound;
              tree tmptype;
              HOST_WIDE_INT idx = 0;
 
              p = c;
+             list = NULL_TREE;
               /* Count the number of consecutive scalar constants.  */
              while (p && !(p->iterator
                            || p->expr->expr_type != EXPR_CONSTANT))
@@ -1331,10 +1332,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                                (gfc_get_pchar_type (p->expr->ts.kind),
                                 se.expr);
 
-                  CONSTRUCTOR_APPEND_ELT (v,
-                                          build_int_cst (gfc_array_index_type,
-                                                         idx++),
-                                          se.expr);
+                 list = tree_cons (build_int_cst (gfc_array_index_type,
+                                                  idx++), se.expr, list);
                  c = p;
                  p = gfc_constructor_next (p);
                }
@@ -1345,7 +1344,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
                                          gfc_index_zero_node, bound);
              tmptype = build_array_type (type, tmptype);
 
-             init = build_constructor (tmptype, v);
+             init = build_constructor_from_list (tmptype, nreverse (list));
              TREE_CONSTANT (init) = 1;
              TREE_STATIC (init) = 1;
              /* Create a static variable to hold the data.  */
@@ -1672,13 +1671,12 @@ gfc_constant_array_constructor_p (gfc_constructor_base base)
 tree
 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
 {
-  tree tmptype, init, tmp;
+  tree tmptype, list, init, tmp;
   HOST_WIDE_INT nelem;
   gfc_constructor *c;
   gfc_array_spec as;
   gfc_se se;
   int i;
-  VEC(constructor_elt,gc) *v = NULL;
 
   /* First traverse the constructor list, converting the constants
      to tree to build an initializer.  */
@@ -1725,7 +1723,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
 
   tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
 
-  init = build_constructor (tmptype, v);
+  init = build_constructor_from_list (tmptype, nreverse (list));
 
   TREE_CONSTANT (init) = 1;
   TREE_STATIC (init) = 1;
@@ -4020,18 +4018,6 @@ 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)
-    {
-      gcc_assert (expr->symtree->n.sym->attr.codimension);
-      return false;
-    }
-  else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
-    {
-      gcc_assert (prev_ref->u.c.component->attr.codimension);
-      return false;
-    }
-
   if (!prev_ref)
     {
       allocatable_array = expr->symtree->n.sym->attr.allocatable;
@@ -4147,10 +4133,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
 {
   gfc_constructor *c;
   tree tmp;
+  mpz_t maxval;
   gfc_se se;
   HOST_WIDE_INT hi;
   unsigned HOST_WIDE_INT lo;
-  tree index;
+  tree index, range;
   VEC(constructor_elt,gc) *v = NULL;
 
   switch (expr->expr_type)
@@ -4231,7 +4218,14 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
            {
            case EXPR_CONSTANT:
              gfc_conv_constant (&se, c->expr);
-             CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+              if (range == NULL_TREE)
+               CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+              else
+                {
+                  if (index != NULL_TREE)
+                   CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+                 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+                }
              break;
 
            case EXPR_STRUCTURE:
@@ -4245,7 +4239,14 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
                 for one reason or another, assuming that if they are
                 standard defying the frontend will catch them.  */
              gfc_conv_expr (&se, c->expr);
-             CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+             if (range == NULL_TREE)
+               CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+             else
+               {
+                 if (index != NULL_TREE)
+                 CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+                 CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+               }
              break;
            }
         }

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index fa214fd..9d53784 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -870,7 +870,7 @@ gfc_init_types (void)
   ppvoid_type_node = build_pointer_type (pvoid_type_node);
   pchar_type_node = build_pointer_type (gfc_character1_type_node);
   pfunc_type_node
-    = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE));
+    = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
 
   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
   /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
@@ -1542,7 +1542,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
 {
   tree fat_type, fieldlist, decl, arraytype;
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
-  int idx = 2 * (codimen + dimen - 1) + restricted;
+  int idx = 2 * (dimen - 1) + restricted;
 
   gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
   if (gfc_array_descriptor_base[idx])
@@ -1551,7 +1551,8 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   /* Build the type node.  */
   fat_type = make_node (RECORD_TYPE);
 
-  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
+  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.  */
@@ -1628,7 +1629,8 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
     type_name = IDENTIFIER_POINTER (tmp);
   else
     type_name = "unknown";
-  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
+  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);
 
@@ -1793,9 +1795,6 @@ gfc_sym_type (gfc_symbol * sym)
                                                restricted);
              byref = 0;
            }
-
-         if (sym->attr.cray_pointee)
-           GFC_POINTER_TYPE_P (type) = 1;
         }
       else
        {
@@ -1811,7 +1810,7 @@ gfc_sym_type (gfc_symbol * sym)
     {
       if (sym->attr.allocatable || sym->attr.pointer)
        type = gfc_build_pointer_type (sym, type);
-      if (sym->attr.pointer || sym->attr.cray_pointee)
+      if (sym->attr.pointer)
        GFC_POINTER_TYPE_P (type) = 1;
     }
 
@@ -1934,7 +1933,7 @@ gfc_get_ppc_type (gfc_component* c)
   else
     t = void_type_node;
 
-  return build_pointer_type (build_function_type_list (t, NULL_TREE));
+  return build_pointer_type (build_function_type (t, NULL_TREE));
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aa6c3f8..a0f62c5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/coarray_12.f90 b/gcc/testsuite/gfortran.dg/coarray_12.f90
index c1b7342..776c819 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_12.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_12.f90
@@ -46,9 +46,9 @@ 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.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.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" } }
 

diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90
index 8cd295d..29af0d1 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_7.f90
+++ b/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