From: burnus Date: Tue, 6 Apr 2010 18:23:56 +0000 (+0000) Subject: 2010-04-06 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=47f214b1a234ead0d9a00bf23e2e7e2e8bbf6e7d 2010-04-06 Tobias Burnus 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 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 f6cfcfdcce2..b1db67aa40d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,6 +1,16 @@ 2010-04-06 Tobias Burnus 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 + + 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 bc4c64057e3..4a110bba0d5 100644 --- 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 a1c3cdba941..c14bcce9423 100644 --- 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 aa16b22dd1e..93200694743 100644 --- 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 7bcade3a7d8..ce2a5e46af8 100644 --- 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 65526d8cd6b..6b0454be275 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,6 +1,12 @@ 2010-04-06 Tobias Burnus PR fortran/18918 + * gfortran.dg/coarray_4.f90: Fix test. + * gfortran.dg/coarray_6.f90: Add more tests. + +2010-04-06 Tobias Burnus + + 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 71fbf98c82d..cb693ea2e04 100644 --- 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 f122fd451f3..b6d8b4952d2 100644 --- 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