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

        PR fortran/18918
        * gfortran.h (gfc_array_spec): Add cotype.
        * array.c (gfc_match_array_spec,gfc_set_array_spec): Use it
        and defer error diagnostic.
        * resolve.c (resolve_fl_derived): Add missing check.
        (resolve_symbol): Add cotype/type check.
        * parse.c (parse_derived): Fix setting of coarray_comp.

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

        PR fortran/18918
        * gfortran.dg/coarray_4.f90: Fix test.
        * gfortran.dg/coarray_6.f90: Add more tests.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f6cfcfd..b1db67a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,6 +1,16 @@
 2010-04-06  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/18918
+       * gfortran.h (gfc_array_spec): Add cotype.
+       * array.c (gfc_match_array_spec,gfc_set_array_spec): Use it
+       and defer error diagnostic.
+       * resolve.c (resolve_fl_derived): Add missing check.
+       (resolve_symbol): Add cotype/type check.
+       * parse.c (parse_derived): Fix setting of coarray_comp.
+
+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.

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index bc4c640..4a110bb 100644 (file)
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -413,7 +413,6 @@ match
 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;
  
@@ -538,23 +537,10 @@ coarray:
       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;
+       as->cotype = current_type;
       else
-       switch (coarray_type)
+       switch (as->cotype)
          { /* See how current spec meshes with the existing.  */
            case AS_UNKNOWN:
              goto cleanup;
@@ -562,7 +548,7 @@ coarray:
            case AS_EXPLICIT:
              if (current_type == AS_ASSUMED_SIZE)
                {
-                 coarray_type = AS_ASSUMED_SIZE;
+                 as->cotype = AS_ASSUMED_SIZE;
                  break;
                }
 
@@ -589,7 +575,7 @@ coarray:
 
              if (current_type == AS_ASSUMED_SHAPE)
                {
-                 as->type = AS_ASSUMED_SHAPE;
+                 as->cotype = AS_ASSUMED_SHAPE;
                  break;
                }
 
@@ -624,10 +610,11 @@ coarray:
       goto cleanup;
     }
 
-  if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
-    as->type = AS_EXPLICIT;
-  else if (as->rank == 0)
-    as->type = coarray_type;
+  if (as->cotype == AS_ASSUMED_SIZE)
+    as->cotype = AS_EXPLICIT;
+
+  if (as->rank == 0)
+    as->type = as->cotype;
 
 done:
   if (as->rank == 0 && as->corank == 0)
@@ -684,26 +671,13 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
       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->cotype = as->cotype;
       sym->as->corank = as->corank;
       for (i = 0; i < as->corank; i++)
        {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a1c3cdb..c14bcce 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -880,7 +880,7 @@ typedef struct
 {
   int rank;    /* A rank of zero means that a variable is a scalar.  */
   int corank;
-  array_type type;
+  array_type type, cotype;
   struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
 
   /* These two fields are used with the Cray Pointer extension.  */

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index aa16b22..9320069 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2101,7 +2101,8 @@ endType:
        sym->attr.proc_pointer_comp = 1;
 
       /* Looking for coarray components.  */
-      if (c->attr.codimension || c->attr.coarray_comp)
+      if (c->attr.codimension
+         || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
        sym->attr.coarray_comp = 1;
 
       /* Look for private components.  */

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7bcade3..ce2a5e4 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10767,7 +10767,8 @@ resolve_fl_derived (gfc_symbol *sym)
 
       /* F2008, C444.  */
       if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
-         && (c->attr.codimension || c->attr.pointer || c->attr.dimension))
+         && (c->attr.codimension || c->attr.pointer || c->attr.dimension
+             || c->attr.allocatable))
        {
          gfc_error ("Component '%s' at %L with coarray component "
                     "shall be a nonpointer, nonallocatable scalar",
@@ -11627,11 +11628,6 @@ resolve_symbol (gfc_symbol *sym)
        }
     }
 
-  if (sym->attr.codimension && sym->attr.allocatable
-      && sym->as->type != AS_DEFERRED)
-    gfc_error ("Allocatable coarray variable '%s' at %L must have "
-              "deferred shape", sym->name, &sym->declared_at);
-
   /* F2008, C526.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
        || sym->attr.codimension)
@@ -11663,6 +11659,16 @@ resolve_symbol (gfc_symbol *sym)
     gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
               "component and is not ALLOCATABLE, SAVE nor a "
               "dummy argument", sym->name, &sym->declared_at);
+  /* F2008, C528.  */
+  else if (sym->attr.codimension && !sym->attr.allocatable
+      && sym->as->cotype == AS_DEFERRED)
+    gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
+               "deferred shape", sym->name, &sym->declared_at);
+  else if (sym->attr.codimension && sym->attr.allocatable
+      && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED))
+    gfc_error ("Allocatable coarray variable '%s' at %L must have "
+              "deferred shape", sym->name, &sym->declared_at);
+
 
   /* F2008, C541.  */
   if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 65526d8..6b0454b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,6 +1,12 @@
 2010-04-06  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/18918
+       * gfortran.dg/coarray_4.f90: Fix test.
+       * gfortran.dg/coarray_6.f90: Add more tests.
+
+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.

diff --git a/gcc/testsuite/gfortran.dg/coarray_4.f90 b/gcc/testsuite/gfortran.dg/coarray_4.f90
index 71fbf98..cb693ea 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_4.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_4.f90
@@ -48,7 +48,7 @@ subroutine invalid(n)
   integer, save :: hf4(5)[n,*] ! { dg-error "cannot have the SAVE attribute" }
 
   integer, allocatable :: a2[*] ! { dg-error "must have deferred shape" }
-  integer, allocatable :: a3(:)[*] ! { dg-error "deferred shape and non-deferred coshape" }
+  integer, allocatable :: a3(:)[*] ! { dg-error "must have deferred shape" }
   integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" }
 end subroutine invalid
 

diff --git a/gcc/testsuite/gfortran.dg/coarray_6.f90 b/gcc/testsuite/gfortran.dg/coarray_6.f90
index f122fd4..b6d8b49 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray_6.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_6.f90
@@ -51,6 +51,32 @@ function func() result(func2) ! { dg-error "shall not be a coarray or have a coa
   type(t) :: func2
 end function func
 
+subroutine invalid()
+  type t
+    integer, allocatable :: a[:]
+  end type t
+  type t2
+    type(t), allocatable :: b ! { dg-error "nonpointer, nonallocatable scalar" }
+  end type t2
+  type t3
+    type(t), pointer :: c ! { dg-error "nonpointer, nonallocatable scalar" }
+  end type t3
+  type t4
+    type(t) :: d(4) ! { dg-error "nonpointer, nonallocatable scalar" }
+  end type t4
+end subroutine invalid
+
+subroutine valid(a)
+  integer :: a(:)[4,-1:6,4:*]
+  type t
+    integer, allocatable :: a[:]
+  end type t
+  type t2
+    type(t) :: b
+  end type t2
+  type(t2), save :: xt2[*]
+end subroutine valid
+
 program main
   integer :: A[*] ! Valid, implicit SAVE attribute
 end program main