This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran, 4.6] Coarray 6/n: Add expression support
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Wed, 31 Mar 2010 19:55:24 +0200
- Subject: Re: [Patch, Fortran, 4.6] Coarray 6/n: Add expression support
- References: <4BA505E5.7070307@net-b.de>
On March 20, 2010 18:29, Tobias Burnus wrote:
> here comes the next coarray patch, which finally brings support for
> coarrays in expression.
>
Attached you find a new version, which corrects some issues.
* * *
First, I managed to confuse "is" and "has" in "is/has an
allocatable/pointer ultimate component" ...
The "for PURE" reference is wrong, C1283 is somewhat different and
checked for at at different place.
gfc_variable_attr mishandled "allocatable" for coarrays, causing
"alloc_var(:)[1] = ..." to be rejected.
And I forgot to to do a rank check for actual arguments to allocatable
coarray formal arguments.
* * *
Hopefully, I have now found most of the bugs ...
Build and regtested on x86-64-linux.
OK for the 4.6 trunk?
(I included both an interdiff and the update of the previous patch as it
was not yet reviewed.)
Tobias
PS: By the way, there is a new version of g95, which is said to also
support coarray via threads, cf. http://www.g95.org/.
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 76bc8a8..7703959 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3878,41 +3878,61 @@ gfc_is_coindexed (gfc_expr *e)
}
-/* Check whether the expression has an allocatable component. */
+/* Check whether the expression has an ultimate allocatable component.
+ Being itself allocatable does not count. */
bool
gfc_has_ultimate_allocatable (gfc_expr *e)
{
gfc_ref *ref, *last = NULL;
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
-
- if (last)
- return (bool) last->u.c.component->attr.allocatable;
- if (e->expr_type == EXPR_VARIABLE)
- return (bool) e->symtree->n.sym->attr.allocatable;
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.alloc_comp;
+ else if (last)
+ return false;
- return false;
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.alloc_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.alloc_comp;
+ else
+ return false;
}
-/* Check whether the expression has an pointer component. */
+/* Check whether the expression has an pointer component.
+ Being itself a pointer does not count. */
bool
gfc_has_ultimate_pointer (gfc_expr *e)
{
gfc_ref *ref, *last = NULL;
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
- if (last)
- return (bool) last->u.c.component->attr.pointer;
-
- if (e->expr_type == EXPR_VARIABLE)
- return (bool) e->symtree->n.sym->attr.pointer;
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.pointer_comp;
+ else if (last)
+ return false;
- return false;
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.pointer_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.pointer_comp;
+ else
+ return false;
}
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index bbe00ca..84d7a13 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1487,6 +1487,20 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
}
if (symbol_rank (formal) == actual->rank)
@@ -2032,15 +2046,25 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
/* Fortran 2008, 12.5.2.5 (no constraint). */
if (a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.intent != INTENT_IN
- && (f->sym->attr.allocatable || f->sym->attr.pointer)
+ && f->sym->attr.allocatable
&& gfc_is_coindexed (a->expr))
{
if (where)
- gfc_error ("Coindexed actual argument at %L to allocatable or "
- "pointer dummy '%s' requires INTENT(IN)",
+ gfc_error ("Coindexed actual argument at %L to allocatable "
+ "dummy '%s' requires INTENT(IN)",
&a->expr->where, f->sym->name);
return 0;
}
@@ -2062,7 +2086,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
/* Fortran 2008, 12.5.2.4 (no constraint). */
if (a->expr->expr_type == EXPR_VARIABLE
- && (f->sym->attr.intent != INTENT_IN || f->sym->attr.value)
+ && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
&& gfc_is_coindexed (a->expr)
&& gfc_has_ultimate_allocatable (a->expr))
{
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 186795e..34b6874 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2050,7 +2050,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
break;
case AR_ELEMENT:
- allocatable = pointer = 0;
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0)
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f7b0010..902c7be 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1563,7 +1563,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
}
- /* Fortran 2008, C1237, for PURE C1283. */
+ /* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
&& gfc_has_ultimate_pointer (e))
{
diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90
index a82f256..a32bf88 100644
--- a/gcc/testsuite/gfortran.dg/coarray_7.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_7.f90
@@ -7,21 +7,37 @@
!
program test
implicit none
+ type t3
+ integer, allocatable :: a
+ end type t3
+ type t4
+ type(t3) :: xt3
+ end type t4
type t
integer, pointer :: ptr
integer, allocatable :: alloc(:)
end type t
type(t), target :: i[*]
+ type(t), allocatable :: ca[:]
+ type(t4), target :: tt4[*]
+ type(t4), allocatable :: ca2[:]
integer, volatile :: volat[*]
integer, asynchronous :: async[*]
integer :: caf1[1,*], caf2[*]
allocate(i%ptr)
call foo(i%ptr)
- call foo(i[1]%ptr) ! { dg-error "with ultimate pointer component" }
+ call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" }
call bar(i%ptr)
- call bar(i[1]%ptr) ! { dg-error "with ultimate pointer component" }
- call bar(i[1]%alloc(1)) ! { dg-error "requires either VALUE or INTENT.IN." }
-
+ call bar(i[1]%ptr) ! OK, value of ptr target
+ call bar(i[1]%alloc(1)) ! OK
+ call typeDummy(i) ! OK
+ call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy2(ca) ! OK
+ call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy3(tt4%xt3) ! OK
+ call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." }
+ call typeDummy4(ca2) ! OK
+ call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." }
! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in)
! is not possible
@@ -34,9 +50,9 @@ program test
call coarray(caf2)
call coarray(caf2[1]) ! { dg-error "must be a coarray" }
call ups(i)
- call ups(i[1])
+ call ups(i[1]) ! { dg-error "with ultimate pointer component" }
call ups(i%ptr)
- call ups(i[1]%ptr) ! { dg-error "with ultimate pointer component" }
+ call ups(i[1]%ptr) ! OK - passes target not pointer
contains
subroutine asyn(a)
integer, intent(in), asynchronous :: a
@@ -50,6 +66,18 @@ contains
subroutine coarray(a)
integer :: a[*]
end subroutine coarray
+ subroutine typeDummy(a)
+ type(t) :: a
+ end subroutine typeDummy
+ subroutine typeDummy2(a)
+ type(t),allocatable :: a
+ end subroutine typeDummy2
+ subroutine typeDummy3(a)
+ type(t3) :: a
+ end subroutine typeDummy3
+ subroutine typeDummy4(a)
+ type(t4), allocatable :: a
+ end subroutine typeDummy4
end program test
diff --git a/gcc/testsuite/gfortran.dg/coarray_8.f90 b/gcc/testsuite/gfortran.dg/coarray_8.f90
index 22478f3..0ab1190 100644
--- a/gcc/testsuite/gfortran.dg/coarray_8.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_8.f90
@@ -80,7 +80,7 @@ contains
x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" }
x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" }
call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" }
- call p3 (x%b[1]%p) ! { dg-error "with ultimate pointer component" }
+ call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" }
end subroutine p1
subroutine nonPtr()
type(t1), save :: a[*]
@@ -91,7 +91,7 @@ contains
a%p => a[2]%p ! { dg-error "shall not have a coindex" }
a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" }
call p2 (b[1]%i) ! OK
- call p2 (a[1]%p) ! { dg-error "with ultimate pointer component" }
+ call p2 (a[1]%p) ! OK - pointer target and not pointer
end subroutine nonPtr
end module m
@@ -105,8 +105,15 @@ contains
type(t) :: x[*]
allocate(x%a(3))
x%a = [ 1, 2, 3]
- x[1]%a = [ 1, 2, 3] ! { dg-error "must not be have an allocatable ultimate component in assignment" }
+ x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong
+ ! (no reallocate on assignment)
end subroutine assign
+ subroutine assign2(x,y)
+ type(t),allocatable :: x[:]
+ type(t) :: y
+ x = y
+ x[1] = y ! { dg-error "must not be have an allocatable ultimate component" }
+ end subroutine assign2
end module mmm3
@@ -162,4 +169,23 @@ subroutine f4f4()
x[1]%ppt => foo ! { dg-error "shall not have a coindex" }
end subroutine f4f4
+
+subroutine corank()
+ integer, allocatable :: a[:,:]
+ call one(a) ! OK
+ call two(a) ! { dg-error "Corank mismatch in argument" }
+contains
+ subroutine one(x)
+ integer :: x[*]
+ end subroutine one
+ subroutine two(x)
+ integer, allocatable :: x[:]
+ end subroutine two
+end subroutine corank
+
+subroutine assign42()
+ integer, allocatable :: z(:)[:]
+ z(:)[1] = z
+end subroutine assign42
+
! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } }
fortran/array.c | 93 +++++++++-
fortran/data.c | 8
fortran/decl.c | 81 ++++++++-
fortran/expr.c | 103 +++++++++++
fortran/gfortran.h | 9 -
fortran/interface.c | 148 ++++++++++++++++
fortran/match.c | 13 +
fortran/match.h | 2
fortran/primary.c | 48 ++++-
fortran/resolve.c | 323 +++++++++++++++++++++++++++++++-----
fortran/trans-array.c | 25 ++
fortran/trans-expr.c | 5
testsuite/gfortran.dg/coarray_7.f90 | 194 +++++++++++++++++++++
testsuite/gfortran.dg/coarray_8.f90 | 191 +++++++++++++++++++++
14 files changed, 1173 insertions(+), 70 deletions(-)
2010-03-31 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* decl.c (variable_decl, match_attr_spec): Fix setting the array
spec.
* array.c (match_subscript,gfc_match_array_ref): Add coarray support.
* data.c (gfc_assign_data_value): Ditto.
* expr.c (gfc_check_pointer_assign): Add check for coarray constraint.
(gfc_traverse_expr): Traverse also through codimension expressions.
(gfc_is_coindexed, gfc_has_ultimate_allocatable,
gfc_has_ultimate_pointer): New functions.
* gfortran.h (gfc_array_ref_dimen_type): Add DIMEN_STAR for coarrays.
(gfc_array_ref): Add codimen.
(gfc_array_ref): Add in_allocate.
(gfc_is_coindexed, gfc_has_ultimate_allocatable,
gfc_has_ultimate_pointer): Add prototypes.
* interface.c (compare_parameter, compare_actual_formal,
check_intents): Add coarray constraints.
* match.c (gfc_match_iterator): Add coarray constraint.
* match.h (gfc_match_array_ref): Update interface.
* primary.c (gfc_match_varspec): Handle codimensions.
(gfc_variable_attr): Ditto.
* resolve.c (coarray_alloc, inquiry_argument): New static variables.
(check_class_members): Return gfc_try instead for error recovery.
(resolve_typebound_function,resolve_typebound_subroutine,
check_members): Handle return value of check_class_members.
(resolve_structure_cons, resolve_actual_arglist, resolve_function,
check_dimension, compare_spec_to_ref, resolve_array_ref,
resolve_ref, resolve_variable, gfc_resolve_expr, conformable_arrays,
resolve_allocate_expr, resolve_ordinary_assign): Add coarray
support.
* trans-array.c (gfc_conv_array_ref, gfc_walk_variable_expr):
Skip over coarray refs.
(gfc_array_allocate) Add support for references containing coindexes.
* trans-expr.c (gfc_add_interface_mapping): Copy coarray attribute.
(gfc_map_intrinsic_function): Ignore codimensions.
2010-03-31 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_7.f90: New test.
* gfortran.dg/coarray_8.f90: New test.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index c291ad8..bc3148c 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src)
expression. */
static match
-match_subscript (gfc_array_ref *ar, int init)
+match_subscript (gfc_array_ref *ar, int init, bool match_star)
{
match m;
+ bool star = false;
int i;
- i = ar->dimen;
+ i = ar->dimen + ar->codimen;
ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
@@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init)
goto end_element;
/* Get start element. */
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+
+ if (!star && init)
m = gfc_match_init_expr (&ar->start[i]);
- else
+ else if (!star)
m = gfc_match_expr (&ar->start[i]);
if (m == MATCH_NO)
@@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init)
return MATCH_ERROR;
if (gfc_match_char (':') == MATCH_NO)
- return MATCH_YES;
+ goto matched;
+
+ if (star)
+ {
+ gfc_error ("Unexpected '*' in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
/* Get an optional end element. Because we've seen the colon, we
definitely have a range along this dimension. */
end_element:
ar->dimen_type[i] = DIMEN_RANGE;
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+ else if (init)
m = gfc_match_init_expr (&ar->end[i]);
else
m = gfc_match_expr (&ar->end[i]);
@@ -110,6 +122,12 @@ end_element:
/* See if we have an optional stride. */
if (gfc_match_char (':') == MATCH_YES)
{
+ if (star)
+ {
+ gfc_error ("Strides not allowed in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
+
m = init ? gfc_match_init_expr (&ar->stride[i])
: gfc_match_expr (&ar->stride[i]);
@@ -119,6 +137,10 @@ end_element:
return MATCH_ERROR;
}
+matched:
+ if (star)
+ ar->dimen_type[i] = DIMEN_STAR;
+
return MATCH_YES;
}
@@ -128,14 +150,23 @@ end_element:
to consist of init expressions. */
match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
+ int corank)
{
match m;
+ bool matched_bracket = false;
memset (ar, '\0', sizeof (ar));
ar->where = gfc_current_locus;
ar->as = as;
+ ar->type = AR_UNKNOWN;
+
+ if (gfc_match_char ('[') == MATCH_YES)
+ {
+ matched_bracket = true;
+ goto coarray;
+ }
if (gfc_match_char ('(') != MATCH_YES)
{
@@ -144,16 +175,17 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
return MATCH_YES;
}
- ar->type = AR_UNKNOWN;
-
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
{
- m = match_subscript (ar, init);
+ m = match_subscript (ar, init, false);
if (m == MATCH_ERROR)
goto error;
if (gfc_match_char (')') == MATCH_YES)
- goto matched;
+ {
+ ar->dimen++;
+ goto coarray;
+ }
if (gfc_match_char (',') != MATCH_YES)
{
@@ -164,12 +196,49 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
gfc_error ("Array reference at %C cannot have more than %d dimensions",
GFC_MAX_DIMENSIONS);
+ goto error;
+
+coarray:
+ if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+ {
+ if (ar->dimen > 0)
+ goto matched;
+ else
+ goto error;
+ }
+
+ if (corank == 0)
+ {
+ gfc_error ("Unexpected coarray designator at %C");
+ goto error;
+ }
+
+ for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+ {
+ m = match_subscript (ar, init, ar->codimen == (corank - 1));
+ if (m == MATCH_ERROR)
+ goto error;
+
+ if (gfc_match_char (']') == MATCH_YES)
+ {
+ ar->codimen++;
+ goto matched;
+ }
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Invalid form of coarray reference at %C");
+ goto error;
+ }
+ }
+
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
error:
return MATCH_ERROR;
matched:
- ar->dimen++;
return MATCH_YES;
}
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 0d04d65..8c79bad 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -289,6 +289,14 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
switch (ref->type)
{
case REF_ARRAY:
+ if (ref->u.ar.as->rank == 0)
+ {
+ gcc_assert (ref->u.ar.as->corank > 0);
+ if (init == NULL)
+ gfc_free (expr);
+ continue;
+ }
+
if (init && expr->expr_type != EXPR_ARRAY)
{
gfc_error ("'%s' at %L already is initialized at %L",
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b376192..eda77ad 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1603,6 +1603,36 @@ variable_decl (int elem)
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
+ else if (current_as && as->corank == 0 && current_as->corank > 0)
+ {
+ int i;
+ as->cotype = current_as->cotype;
+ as->corank = current_as->corank;
+ for (i = 0; i < current_as->corank; i++)
+ {
+ as->lower[as->rank + i] = gfc_copy_expr (current_as->lower[i]);
+ as->upper[as->rank + i] = gfc_copy_expr (current_as->upper[i]);
+ }
+ }
+ else if (current_as && as->rank == 0 && current_as->rank > 0)
+ {
+ int i;
+ as->rank = current_as->rank;
+ as->type = current_as->type;
+ as->cray_pointee = current_as->cray_pointee;
+ as->cp_was_assumed = current_as->cp_was_assumed;
+
+ for (i = 0; i < as->corank; i++)
+ {
+ as->lower[current_as->rank + i] = as->lower[i];
+ as->upper[current_as->rank + i] = as->upper[i];
+ }
+ for (i = 0; i < current_as->rank; i++)
+ {
+ as->lower[i] = gfc_copy_expr (current_as->lower[i]);
+ as->upper[i] = gfc_copy_expr (current_as->upper[i]);
+ }
+ }
char_len = NULL;
cl = NULL;
@@ -3052,7 +3082,34 @@ match_attr_spec (void)
if (d == DECL_DIMENSION)
{
- m = gfc_match_array_spec (¤t_as, true, false);
+ gfc_array_spec *as = NULL;
+
+ m = gfc_match_array_spec (&as, true, false);
+ if (current_as == NULL)
+ current_as = as;
+ else if (m == MATCH_YES)
+ {
+ int i;
+ gcc_assert (current_as->rank == 0 && current_as->corank > 0
+ && as->rank > 0 && as->corank == 0);
+ current_as->rank = as->rank;
+ current_as->type = as->type;
+ current_as->cray_pointee = as->cray_pointee;
+ current_as->cp_was_assumed = as->cp_was_assumed;
+
+ for (i = 0; i < current_as->corank; i++)
+ {
+ current_as->lower[as->rank + i] = current_as->lower[i];
+ current_as->upper[as->rank + i] = current_as->upper[i];
+ }
+ for (i = 0; i < as->rank; i++)
+ {
+ current_as->lower[i] = as->lower[i];
+ current_as->upper[i] = as->upper[i];
+ }
+
+ gfc_free (as);
+ }
if (m == MATCH_NO)
{
@@ -3066,7 +3123,27 @@ match_attr_spec (void)
if (d == DECL_CODIMENSION)
{
- m = gfc_match_array_spec (¤t_as, false, true);
+ gfc_array_spec *as = NULL;
+
+ m = gfc_match_array_spec (&as, false, true);
+ if (current_as == NULL)
+ current_as = as;
+ else if (m == MATCH_YES)
+ {
+ int i;
+ gcc_assert (current_as->corank == 0 && current_as->rank > 0
+ && as->corank > 0 && as->rank == 0);
+ current_as->corank = as->corank;
+ current_as->cotype = as->cotype;
+
+ for (i = 0; i < as->corank; i++)
+ {
+ current_as->lower[current_as->rank + i] = as->lower[i];
+ current_as->upper[current_as->rank + i] = as->upper[i];
+ }
+
+ gfc_free (as);
+ }
if (m == MATCH_NO)
{
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 58c9063..7703959 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3204,6 +3204,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */
+ if (lvalue->expr_type == EXPR_VARIABLE
+ && gfc_is_coindexed (lvalue))
+ {
+ gfc_ref *ref;
+ for (ref = lvalue->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("Pointer object at %L shall not have a coindex",
+ &lvalue->where);
+ return FAILURE;
+ }
+ }
+
/* Checks on rvalue for procedure pointer assignments. */
if (proc_pointer)
{
@@ -3368,6 +3382,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE;
}
+ /* F2008, C725. For PURE also C1283. */
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && gfc_is_coindexed (rvalue))
+ {
+ gfc_ref *ref;
+ for (ref = rvalue->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("Data target at %L shall not have a coindex",
+ &rvalue->where);
+ return FAILURE;
+ }
+ }
+
return SUCCESS;
}
@@ -3641,7 +3669,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
return true;
if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
+ for (i = 0; i < ref->u.c.component->as->rank
+ + ref->u.c.component->as->corank; i++)
{
if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
sym, func, f))
@@ -3835,3 +3864,75 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
}
+
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return true;
+
+ return false;
+}
+
+
+/* Check whether the expression has an ultimate allocatable component.
+ Being itself allocatable does not count. */
+bool
+gfc_has_ultimate_allocatable (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.alloc_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.alloc_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.alloc_comp;
+ else
+ return false;
+}
+
+
+/* Check whether the expression has an pointer component.
+ Being itself a pointer does not count. */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.pointer_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.pointer_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.pointer_comp;
+ else
+ return false;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fb29bde..2dd3715 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1436,13 +1436,15 @@ extern gfc_interface_info current_interface;
enum gfc_array_ref_dimen_type
{
- DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN
+ DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
};
typedef struct gfc_array_ref
{
ar_type type;
int dimen; /* # of components in the reference */
+ int codimen;
+ bool in_allocate; /* For coarray checks. */
locus where;
gfc_array_spec *as;
@@ -2633,6 +2635,11 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
+bool gfc_is_coindexed (gfc_expr *);
+bool gfc_has_ultimate_allocatable (gfc_expr *);
+bool gfc_has_ultimate_pointer (gfc_expr *);
+
+
/* st.c */
extern gfc_code new_st;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7bccaa6..84d7a13 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1444,6 +1444,65 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return 0;
}
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
+
+ if (actual->expr_type != EXPR_VARIABLE
+ || (actual->ref == NULL
+ && !actual->symtree->n.sym->attr.codimension))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+ && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and thus shall not have an array designator",
+ formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+ }
+
+ if (last && !last->u.c.component->attr.codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
+ }
+
if (symbol_rank (formal) == actual->rank)
return 1;
@@ -1452,10 +1511,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|| formal->as->type == AS_DEFERRED)
&& actual->expr_type != EXPR_NULL;
+ /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
if (rank_check || ranks_must_agree
|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|| (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
- || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+ || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+ || (actual->rank == 0 && formal->attr.dimension
+ && gfc_is_coindexed (actual)))
{
if (where)
gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
@@ -1473,7 +1535,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
- (F2003) if the actual argument is of type character. */
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0)
break;
/* Not an array element. */
@@ -1983,6 +2046,57 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return 0;
}
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.5 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN
+ && f->sym->attr.allocatable
+ && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to allocatable "
+ "dummy '%s' requires INTENT(IN)",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, C1237. */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+ && gfc_is_coindexed (a->expr)
+ && (a->expr->symtree->n.sym->attr.volatile_
+ || a->expr->symtree->n.sym->attr.asynchronous))
+ {
+ if (where)
+ gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+ "at %L requires that dummy %s' has neither "
+ "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+ f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.4 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+ && gfc_is_coindexed (a->expr)
+ && gfc_has_ultimate_allocatable (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L with allocatable "
+ "ultimate component to dummy '%s' requires either VALUE "
+ "or INTENT(IN)", &a->expr->where, f->sym->name);
+ return 0;
+ }
+
if (a->expr->expr_type != EXPR_NULL
&& compare_allocatable (f->sym, a->expr) == 0)
{
@@ -2366,6 +2480,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
return FAILURE;
}
}
+
+ /* Fortran 2008, C1283. */
+ if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+ {
+ if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to an INTENT(%s) argument",
+ &a->expr->where, gfc_intent_string (f_intent));
+ return FAILURE;
+ }
+
+ if (f->sym->attr.pointer)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to a POINTER dummy argument",
+ &a->expr->where);
+ return FAILURE;
+ }
+ }
+
+ /* F2008, Section 12.5.2.4. */
+ if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+ && gfc_is_coindexed (a->expr))
+ {
+ gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+ "polymorphic dummy argument '%s'",
+ &a->expr->where, f->sym->name);
+ return FAILURE;
+ }
}
return SUCCESS;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index ba65a62..0d8518b 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -949,6 +949,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
locus start;
match m;
+ e1 = e2 = e3 = NULL;
+
/* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
@@ -962,9 +964,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
if (m != MATCH_YES)
return MATCH_NO;
- gfc_match_char ('=');
-
- e1 = e2 = e3 = NULL;
+ /* F2008, C617 & C565. */
+ if (var->symtree->n.sym->attr.codimension)
+ {
+ gfc_error ("Loop variable at %C cannot be a coarray");
+ goto cleanup;
+ }
if (var->ref != NULL)
{
@@ -979,6 +984,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
goto cleanup;
}
+ gfc_match_char ('=');
+
var->symtree->n.sym->attr.implied_index = 1;
m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 7894716..319a02e 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -216,7 +216,7 @@ match gfc_match_init_expr (gfc_expr **);
/* array.c. */
match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
match gfc_match_array_constructor (gfc_expr **);
/* interface.c. */
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 113729f..34b6874 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1746,7 +1746,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
tail = NULL;
gfc_gobble_whitespace ();
+
+ if (gfc_peek_ascii_char () == '[')
+ {
+ if (sym->attr.dimension)
+ {
+ gfc_error ("Array section designator, e.g. '(:)', is required "
+ "besides the coarray designator '[...]' at %C");
+ return MATCH_ERROR;
+ }
+ if (!sym->attr.codimension)
+ {
+ gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+ sym->name);
+ return MATCH_ERROR;
+ }
+ }
+
if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ || gfc_peek_ascii_char () == '[' || sym->attr.codimension
|| (sym->attr.dimension && !sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (primary, NULL)
&& !(gfc_matching_procptr_assignment
@@ -1761,7 +1779,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
tail->type = REF_ARRAY;
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag);
+ equiv_flag, sym->as ? sym->as->corank : 0);
if (m != MATCH_YES)
return m;
@@ -1771,7 +1789,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
if (m != MATCH_YES)
return m;
}
@@ -1881,7 +1899,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+ component->as->corank);
if (m != MATCH_YES)
return m;
}
@@ -1894,7 +1913,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
m = gfc_match_array_ref (&tail->u.ar,
component->ts.u.derived->components->as,
- equiv_flag);
+ equiv_flag,
+ component->ts.u.derived->components->as->corank);
if (m != MATCH_YES)
return m;
}
@@ -1949,6 +1969,13 @@ check_substring:
}
}
+ /* F2008, C727. */
+ if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+ {
+ gfc_error ("Coindexed procedure-pointer component at %C");
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
@@ -2023,7 +2050,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
break;
case AR_ELEMENT:
- allocatable = pointer = 0;
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0)
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
@@ -2349,6 +2378,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
if (m == MATCH_ERROR)
goto cleanup;
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component '%s' in "
+ "structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+
+
/* If not explicitly a parent constructor, gather up the components
and build one. */
if (comp && comp == sym->components
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3ec454e..902c7be 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -77,6 +77,8 @@ static int current_entry_id;
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
+static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
@@ -939,6 +941,17 @@ resolve_structure_cons (gfc_expr *expr)
"component '%s' at %L in PURE procedure", comp->name,
&cons->expr->where);
}
+
+ /* F2003, C1272 (3). */
+ if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ {
+ t = FAILURE;
+ gfc_error ("Invalid expression in the derived type constructor for pointer "
+ "component '%s' at %L in PURE procedure", comp->name,
+ &cons->expr->where);
+ }
}
return t;
@@ -1319,7 +1332,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_expr *e;
int save_need_full_assumed_size;
gfc_component *comp;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
@@ -1549,6 +1562,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
}
}
+
+ /* Fortran 2008, C1237. */
+ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ "component", &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
@@ -2590,11 +2612,16 @@ resolve_function (gfc_expr *expr)
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
+ if (expr->value.function.isym && expr->value.function.isym->inquiry)
+ inquiry_argument = true;
no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+
if (resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args) == FAILURE)
return FAILURE;
+ inquiry_argument = false;
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
@@ -3755,6 +3782,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{
mpz_t last_value;
+ if (ar->dimen_type[i] == DIMEN_STAR)
+ {
+ gcc_assert (ar->stride[i] == NULL);
+ /* This implies [*] as [*:] and [*:3] are not possible. */
+ if (ar->start[i] == NULL)
+ {
+ gcc_assert (ar->end[i] == NULL);
+ return SUCCESS;
+ }
+ }
+
/* Given start, end and stride values, calculate the minimum and
maximum referenced indexes. */
@@ -3763,21 +3801,37 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
case DIMEN_VECTOR:
break;
+ case DIMEN_STAR:
+ /* Check only the lower bound as the upper one is '*'. */
case DIMEN_ELEMENT:
if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld < %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->lower[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld < %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->lower[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
{
- gfc_warning ("Array reference at %L is out of bounds "
- "(%ld > %ld) in dimension %d", &ar->c_where[i],
- mpz_get_si (ar->start[i]->value.integer),
- mpz_get_si (as->upper[i]->value.integer), i+1);
+ if (i < as->rank)
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in dimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer), i+1);
+ else
+ gfc_warning ("Array reference at %L is out of bounds "
+ "(%ld > %ld) in codimension %d", &ar->c_where[i],
+ mpz_get_si (ar->start[i]->value.integer),
+ mpz_get_si (as->upper[i]->value.integer),
+ i + 1 - as->rank);
return SUCCESS;
}
@@ -3897,10 +3951,32 @@ compare_spec_to_ref (gfc_array_ref *ar)
return FAILURE;
}
+ /* ar->codimen == 0 is a local array. */
+ if (as->corank != ar->codimen && ar->codimen != 0)
+ {
+ gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
+ &ar->where, ar->codimen, as->corank);
+ return FAILURE;
+ }
+
for (i = 0; i < as->rank; i++)
if (check_dimension (i, ar, as) == FAILURE)
return FAILURE;
+ /* Local access has no coarray spec. */
+ if (ar->codimen != 0)
+ for (i = as->rank; i < as->rank + as->corank; i++)
+ {
+ if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate)
+ {
+ gfc_error ("Coindex of codimension %d must be a scalar at %L",
+ i + 1 - as->rank, &ar->where);
+ return FAILURE;
+ }
+ if (check_dimension (i, ar, as) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}
@@ -4069,7 +4145,7 @@ resolve_array_ref (gfc_array_ref *ar)
int i, check_scalar;
gfc_expr *e;
- for (i = 0; i < ar->dimen; i++)
+ for (i = 0; i < ar->dimen + ar->codimen; i++)
{
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
@@ -4103,6 +4179,9 @@ resolve_array_ref (gfc_array_ref *ar)
}
}
+ if (ar->type == AR_FULL && ar->as->rank == 0)
+ ar->type = AR_ELEMENT;
+
/* If the reference type is unknown, figure out what kind it is. */
if (ar->type == AR_UNKNOWN)
@@ -4307,6 +4386,13 @@ resolve_ref (gfc_expr *expr)
switch (ref->u.ar.type)
{
case AR_FULL:
+ /* Coarray scalar. */
+ if (ref->u.ar.as->rank == 0)
+ {
+ current_part_dimension = 0;
+ break;
+ }
+ /* Fall through. */
case AR_SECTION:
current_part_dimension = 1;
break;
@@ -4576,6 +4662,47 @@ resolve_procedure:
if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE)
t = FAILURE;
+ /* F2008, C617 and C1229. */
+ if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED)
+ && gfc_is_coindexed (e))
+ {
+ gfc_ref *ref, *ref2 = NULL;
+
+ if (e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT)
+ ref2 = ref;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ break;
+ }
+
+ for ( ; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ break;
+
+ /* Expression itself is coindexed object. */
+ if (ref == NULL)
+ {
+ gfc_component *c;
+ c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+ for ( ; c; c = c->next)
+ if (c->attr.allocatable && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Coindexed object with polymorphic allocatable "
+ "subcomponent at %L", &e->where);
+ t = FAILURE;
+ break;
+ }
+ }
+ }
+
return t;
}
@@ -5163,7 +5290,7 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
of f03 OOP. As soon as vtables are in place and contain pointers
to methods, this will no longer be necessary. */
static gfc_expr *list_e;
-static void check_class_members (gfc_symbol *);
+static gfc_try check_class_members (gfc_symbol *);
static gfc_try class_try;
static bool fcn_flag;
@@ -5172,11 +5299,11 @@ static void
check_members (gfc_symbol *derived)
{
if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
+ (void) check_class_members (derived);
}
-static void
+static gfc_try
check_class_members (gfc_symbol *derived)
{
gfc_expr *e;
@@ -5193,7 +5320,7 @@ check_class_members (gfc_symbol *derived)
{
gfc_error ("no typebound available procedure named '%s' at %L",
e->value.compcall.name, &e->where);
- return;
+ return FAILURE;
}
/* If we have to match a passed class member, force the actual
@@ -5203,6 +5330,9 @@ check_class_members (gfc_symbol *derived)
if (e->value.compcall.base_object == NULL)
e->value.compcall.base_object = extract_compcall_passed_object (e);
+ if (e->value.compcall.base_object == NULL)
+ return FAILURE;
+
if (!derived->attr.abstract)
{
e->value.compcall.base_object->ts.type = BT_DERIVED;
@@ -5240,6 +5370,8 @@ check_class_members (gfc_symbol *derived)
/* Burrow down into grandchildren types. */
if (derived->f2k_derived)
gfc_traverse_ns (derived->f2k_derived, check_members);
+
+ return SUCCESS;
}
@@ -5393,7 +5525,9 @@ resolve_typebound_function (gfc_expr* e)
class_try = SUCCESS;
fcn_flag = true;
list_e = gfc_copy_expr (e);
- check_class_members (derived);
+
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
class_try = (resolve_compcall (e, true, false) == SUCCESS)
? class_try : FAILURE;
@@ -5453,7 +5587,9 @@ resolve_typebound_subroutine (gfc_code *code)
class_try = SUCCESS;
fcn_flag = false;
list_e = gfc_copy_expr (code->expr1);
- check_class_members (derived);
+
+ if (check_class_members (derived) == FAILURE)
+ return FAILURE;
class_try = (resolve_typebound_call (code) == SUCCESS)
? class_try : FAILURE;
@@ -5585,10 +5721,15 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
+ bool inquiry_save;
if (e == NULL)
return SUCCESS;
+ inquiry_save = inquiry_argument;
+ if (e->expr_type != EXPR_VARIABLE)
+ inquiry_argument = false;
+
switch (e->expr_type)
{
case EXPR_OP:
@@ -5676,6 +5817,8 @@ gfc_resolve_expr (gfc_expr *e)
if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl)
fixup_charlen (e);
+ inquiry_argument = inquiry_save;
+
return t;
}
@@ -6122,7 +6265,9 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
- int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
+ int i, pointer, allocatable, dimension, check_intent_in, is_abstract,
+ coindexed = false;
+ int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_array_ref *ar;
@@ -6134,8 +6279,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
+ /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
+ checking of coarrays. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+
+ if (ref && ref->type == REF_ARRAY)
+ ref->u.ar.in_allocate = true;
+
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
@@ -6153,6 +6307,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
+ codimension = attr.codimension;
}
else
{
@@ -6161,6 +6316,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
allocatable = sym->ts.u.derived->components->attr.allocatable;
pointer = sym->ts.u.derived->components->attr.pointer;
dimension = sym->ts.u.derived->components->attr.dimension;
+ codimension = sym->ts.u.derived->components->attr.codimension;
is_abstract = sym->ts.u.derived->components->attr.abstract;
}
else
@@ -6168,6 +6324,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
allocatable = sym->attr.allocatable;
pointer = sym->attr.pointer;
dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
@@ -6178,17 +6335,27 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
switch (ref->type)
{
case REF_ARRAY:
+ coindexed = coindexed ? true : ref->u.ar.codimen > 0;
if (ref->next != NULL)
pointer = 0;
break;
case REF_COMPONENT:
+ /* F2008, C644. */
+ if (gfc_is_coindexed (e))
+ {
+ gfc_error ("Coindexed allocatable object at %L",
+ &e->where);
+ goto failure;
+ }
+
c = ref->u.c.component;
if (c->ts.type == BT_CLASS)
{
allocatable = c->ts.u.derived->components->attr.allocatable;
pointer = c->ts.u.derived->components->attr.pointer;
dimension = c->ts.u.derived->components->attr.dimension;
+ codimension = c->ts.u.derived->components->attr.codimension;
is_abstract = c->ts.u.derived->components->attr.abstract;
}
else
@@ -6196,6 +6363,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
allocatable = c->attr.allocatable;
pointer = c->attr.pointer;
dimension = c->attr.dimension;
+ codimension = c->attr.codimension;
is_abstract = c->attr.abstract;
}
break;
@@ -6212,7 +6380,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
&e->where);
- return FAILURE;
+ goto failure;
}
/* Some checks for the SOURCE tag. */
@@ -6223,13 +6391,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
gfc_error ("Type of entity at %L is type incompatible with "
"source-expr at %L", &e->where, &code->expr3->where);
- return FAILURE;
+ goto failure;
}
/* Check F03:C632 and restriction following Note 6.18. */
if (code->expr3->rank > 0
&& conformable_arrays (code->expr3, e) == FAILURE)
- return FAILURE;
+ goto failure;
/* Check F03:C633. */
if (code->expr3->ts.kind != e->ts.kind)
@@ -6237,7 +6405,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
gfc_error ("The allocate-object at %L and the source-expr at %L "
"shall have the same kind type parameter",
&e->where, &code->expr3->where);
- return FAILURE;
+ goto failure;
}
}
else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN)
@@ -6245,14 +6413,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
"type-spec or SOURCE=", sym->name, &e->where);
- return FAILURE;
+ goto failure;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
sym->name, &e->where);
- return FAILURE;
+ goto failure;
}
if (!code->expr3)
@@ -6285,16 +6453,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
}
}
- if (pointer || dimension == 0)
- return SUCCESS;
+ if (pointer || (dimension == 0 && codimension == 0))
+ goto success;
/* Make sure the next-to-last reference node is an array specification. */
- if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
+ if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
+ || (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
"at %L", &e->where);
- return FAILURE;
+ goto failure;
}
/* Make sure that the array section reference makes sense in the
@@ -6302,6 +6471,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
ar = &ref2->u.ar;
+ if (codimension && ar->codimen == 0)
+ {
+ gfc_error ("Coarray specification required in ALLOCATE statement "
+ "at %L", &e->where);
+ goto failure;
+ }
+
for (i = 0; i < ar->dimen; i++)
{
if (ref2->u.ar.type == AR_ELEMENT)
@@ -6322,13 +6498,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
case DIMEN_UNKNOWN:
case DIMEN_VECTOR:
+ case DIMEN_STAR:
gfc_error ("Bad array specification in ALLOCATE statement at %L",
&e->where);
- return FAILURE;
+ goto failure;
}
check_symbols:
-
for (a = code->ext.alloc.list; a; a = a->next)
{
sym = a->expr->symtree->n.sym;
@@ -6345,12 +6521,46 @@ check_symbols:
gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
- return FAILURE;
+ goto failure;
}
}
}
+ for (i = ar->dimen; i < ar->codimen + ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_ELEMENT
+ || ar->dimen_type[i] == DIMEN_RANGE)
+ {
+ if (i == (ar->dimen + ar->codimen - 1))
+ {
+ gfc_error ("Expected '*' in coindex specification in ALLOCATE "
+ "statement at %L", &e->where);
+ goto failure;
+ }
+ break;
+ }
+
+ if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1)
+ && ar->stride[i] == NULL)
+ break;
+
+ gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
+ &e->where);
+ goto failure;
+ }
+
+ if (codimension)
+ {
+ gfc_error ("Sorry, allocatable coarrays are no yet supported coarray at %L",
+ &e->where);
+ goto failure;
+ }
+
+success:
return SUCCESS;
+
+failure:
+ return FAILURE;
}
static void
@@ -8031,17 +8241,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
&& rhs->expr_type == EXPR_VARIABLE
- && gfc_impure_variable (rhs->symtree->n.sym))
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ {
+ /* F2008, C1283. */
+ if (gfc_is_coindexed (rhs))
+ gfc_error ("Coindexed expression at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure",
+ &rhs->where);
+ else
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &rhs->where);
+ return rval;
+ }
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
{
- gfc_error ("The impure variable at %L is assigned to "
- "a derived type variable with a POINTER "
- "component in a PURE procedure (12.6)",
- &rhs->where);
+ gfc_error ("Assignment to coindexed variable at %L in a PURE "
+ "procedure", &rhs->where);
return rval;
}
}
/* F03:7.4.1.2. */
+ /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
+ and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
if (lhs->ts.type == BT_CLASS)
{
gfc_error ("Variable must not be polymorphic in assignment at %L",
@@ -8049,6 +8277,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
return false;
}
+ /* F2008, Section 7.2.1.2. */
+ if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+ {
+ gfc_error ("Coindexed variable must not be have an allocatable ultimate "
+ "component in assignment at %L", &lhs->where);
+ return false;
+ }
+
gfc_check_assign (lhs, rhs, 1);
return false;
}
@@ -10462,8 +10698,8 @@ resolve_fl_derived (gfc_symbol *sym)
for (c = sym->components; c != NULL; c = c->next)
{
/* F2008, C442. */
- if (c->attr.codimension
- && (!c->attr.allocatable || c->as->type != AS_DEFERRED))
+ if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */
+ && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component '%s' at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
@@ -11351,9 +11587,9 @@ 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. */
+ /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
else if (sym->attr.codimension && !sym->attr.allocatable
- && sym->as->cotype == AS_DEFERRED)
+ && sym->as && 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
@@ -11548,6 +11784,13 @@ check_data_variable (gfc_data_variable *var, locus *where)
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
has_pointer = 1;
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ {
+ gfc_error ("DATA element '%s' at %L cannot have a coindex",
+ sym->name, where);
+ return FAILURE;
+ }
+
if (has_pointer
&& ref->type == REF_ARRAY
&& ref->u.ar.type != AR_FULL)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5eeead8..2326cf0 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
gfc_se indexse;
gfc_se tmpse;
+ if (ar->dimen == 0)
+ return;
+
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
{
@@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+ || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
prev_ref = ref;
ref = ref->next;
}
@@ -3966,6 +3970,18 @@ 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;
else
@@ -6338,6 +6354,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
continue;
ar = &ref->u.ar;
+
+ if (ar->as->rank == 0)
+ {
+ /* Scalar coarray. */
+ continue;
+ }
+
switch (ar->type)
{
case AR_ELEMENT:
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b9ea557..abe1ed3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1848,6 +1848,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
new_sym->as = gfc_copy_array_spec (sym->as);
new_sym->attr.referenced = 1;
new_sym->attr.dimension = sym->attr.dimension;
+ new_sym->attr.codimension = sym->attr.codimension;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
@@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
break;
case GFC_ISYM_SIZE:
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
@@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
/* TODO These implementations of lbound and ubound do not limit if
the size < 0, according to F95's 13.14.53 and 13.14.113. */
- if (!sym->as)
+ if (!sym->as || sym->as->rank == 0)
return false;
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90
new file mode 100644
index 0000000..a32bf88
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_7.f90
@@ -0,0 +1,194 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+program test
+ implicit none
+ type t3
+ integer, allocatable :: a
+ end type t3
+ type t4
+ type(t3) :: xt3
+ end type t4
+ type t
+ integer, pointer :: ptr
+ integer, allocatable :: alloc(:)
+ end type t
+ type(t), target :: i[*]
+ type(t), allocatable :: ca[:]
+ type(t4), target :: tt4[*]
+ type(t4), allocatable :: ca2[:]
+ integer, volatile :: volat[*]
+ integer, asynchronous :: async[*]
+ integer :: caf1[1,*], caf2[*]
+ allocate(i%ptr)
+ call foo(i%ptr)
+ call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" }
+ call bar(i%ptr)
+ call bar(i[1]%ptr) ! OK, value of ptr target
+ call bar(i[1]%alloc(1)) ! OK
+ call typeDummy(i) ! OK
+ call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy2(ca) ! OK
+ call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" }
+ call typeDummy3(tt4%xt3) ! OK
+ call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." }
+ call typeDummy4(ca2) ! OK
+ call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." }
+! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in)
+! is not possible
+
+ call asyn(volat)
+ call asyn(async)
+ call asyn(volat[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+ call asyn(async[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" }
+
+ call coarray(caf1) ! rank mismatch; OK, for non allocatable coarrays
+ call coarray(caf2)
+ call coarray(caf2[1]) ! { dg-error "must be a coarray" }
+ call ups(i)
+ call ups(i[1]) ! { dg-error "with ultimate pointer component" }
+ call ups(i%ptr)
+ call ups(i[1]%ptr) ! OK - passes target not pointer
+contains
+ subroutine asyn(a)
+ integer, intent(in), asynchronous :: a
+ end subroutine asyn
+ subroutine bar(a)
+ integer :: a
+ end subroutine bar
+ subroutine foo(a)
+ integer, pointer :: a
+ end subroutine foo
+ subroutine coarray(a)
+ integer :: a[*]
+ end subroutine coarray
+ subroutine typeDummy(a)
+ type(t) :: a
+ end subroutine typeDummy
+ subroutine typeDummy2(a)
+ type(t),allocatable :: a
+ end subroutine typeDummy2
+ subroutine typeDummy3(a)
+ type(t3) :: a
+ end subroutine typeDummy3
+ subroutine typeDummy4(a)
+ type(t4), allocatable :: a
+ end subroutine typeDummy4
+end program test
+
+
+subroutine alloc()
+type t
+ integer, allocatable :: a(:)
+end type t
+type(t), save :: a[*]
+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
+
+
+subroutine dataPtr()
+ integer, save, target :: a[*]
+ data a/5/ ! OK
+ data a[1]/5/ ! { dg-error "cannot have a coindex" }
+ type t
+ integer, pointer :: p
+ end type t
+ type(t), save :: x[*]
+
+ type t2
+ integer :: a(1)
+ end type t2
+ type(t2) y
+ data y%a/4/
+
+
+ x[1]%p => a ! { dg-error "shall not have a coindex" }
+ x%p => a[1] ! { dg-error "shall not have a coindex" }
+end subroutine dataPtr
+
+
+subroutine test3()
+implicit none
+type t
+ integer :: a(1)
+end type t
+type(t), save :: x[*]
+data x%a/4/
+
+ integer, save :: y(1)[*] !(1)
+ call sub(x(1:1)[1]) ! { dg-error "Rank mismatch" }
+contains
+ subroutine sub(a) ! { dg-error "shall not have codimensions with deferred shape" }
+ integer :: a(:)[:]
+ end subroutine sub
+end subroutine test3
+
+
+subroutine test4()
+ integer, save :: i[*]
+ integer :: j
+ call foo(i)
+ call foo(j) ! { dg-error "must be a coarray" }
+contains
+ subroutine foo(a)
+ integer :: a[*]
+ end subroutine foo
+end subroutine test4
+
+
+subroutine allocateTest()
+ implicit none
+ real, allocatable,dimension(:,:), 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" }
+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
+ double precision, allocatable :: array(:)
+ end type co_double_3
+ type(co_double_3),save, codimension[*] :: work
+ allocate(work%array(1))
+ print *, size(work%array)
+end subroutine testAlloc4
+
+subroutine test5()
+ implicit none
+ integer, save :: i[*]
+ print *, i[*] ! { dg-error "Coindex of codimension 1 must be a scalar" }
+end subroutine test5
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_8.f90 b/gcc/testsuite/gfortran.dg/coarray_8.f90
new file mode 100644
index 0000000..0ab1190
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_8.f90
@@ -0,0 +1,191 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000" }
+!
+! PR fortran/18918
+!
+! Coarray expressions.
+!
+module mod2
+ implicit none
+ type t
+ procedure(sub), pointer :: ppc
+ contains
+ procedure :: tbp => sub
+ end type t
+ type t2
+ class(t), allocatable :: poly
+ end type t2
+contains
+ subroutine sub(this)
+ class(t), intent(in) :: this
+ end subroutine sub
+end module mod2
+
+subroutine procTest(y,z)
+ use mod2
+ implicit none
+ type(t), save :: x[*]
+ type(t) :: y[*]
+ type(t2) :: z[*]
+
+ x%ppc => sub
+ call x%ppc() ! OK
+ call x%tbp() ! OK
+ call x[1]%tbp ! OK, not polymorphic
+ ! Invalid per C726
+ call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+ y%ppc => sub
+ call y%ppc() ! OK
+ call y%tbp() ! OK
+ call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj.
+ call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
+
+ ! Invalid per C1229
+ z%poly%ppc => sub
+ call z%poly%ppc() ! OK
+ call z%poly%tbp() ! OK
+ call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" }
+ call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" }
+end subroutine procTest
+
+
+module m
+ type t1
+ integer, pointer :: p
+ end type t1
+ type t2
+ integer :: i
+ end type t2
+ type t
+ integer, allocatable :: a[:]
+ type(t1), allocatable :: b[:]
+ type(t2), allocatable :: c[:]
+ end type t
+contains
+ pure subroutine p2(x)
+ integer, intent(inout) :: x
+ end subroutine p2
+ pure subroutine p3(x)
+ integer, pointer :: x
+ end subroutine p3
+ pure subroutine p1(x)
+ type(t), intent(inout) :: x
+ integer, target :: tgt1
+ x%a = 5
+ x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" }
+ x%b%p => tgt1
+ x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+ x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" }
+ x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+ x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" }
+ call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" }
+ call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" }
+ end subroutine p1
+ subroutine nonPtr()
+ type(t1), save :: a[*]
+ type(t2), save :: b[*]
+ integer, target :: tgt1
+ a%p => tgt1
+ a[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
+ a%p => a[2]%p ! { dg-error "shall not have a coindex" }
+ a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" }
+ call p2 (b[1]%i) ! OK
+ call p2 (a[1]%p) ! OK - pointer target and not pointer
+ end subroutine nonPtr
+end module m
+
+
+module mmm3
+ type t
+ integer, allocatable :: a(:)
+ end type t
+contains
+ subroutine assign(x)
+ type(t) :: x[*]
+ allocate(x%a(3))
+ x%a = [ 1, 2, 3]
+ x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong
+ ! (no reallocate on assignment)
+ end subroutine assign
+ subroutine assign2(x,y)
+ type(t),allocatable :: x[:]
+ type(t) :: y
+ x = y
+ x[1] = y ! { dg-error "must not be have an allocatable ultimate component" }
+ end subroutine assign2
+end module mmm3
+
+
+module mmm4
+ implicit none
+contains
+ subroutine t1(x)
+ integer :: x(1)
+ end subroutine t1
+ subroutine t3(x)
+ character :: x(*)
+ end subroutine t3
+ subroutine t2()
+ integer, save :: x[*]
+ integer, save :: y(1)[*]
+ character(len=20), save :: z[*]
+
+ call t1(x) ! { dg-error "Rank mismatch" }
+ call t1(x[1]) ! { dg-error "Rank mismatch" }
+
+ call t1(y(1)) ! OK
+ call t1(y(1)[1]) ! { dg-error "Rank mismatch" }
+
+ call t3(z) ! OK
+ call t3(z[1]) ! { dg-error "Rank mismatch" }
+ end subroutine t2
+end module mmm4
+
+
+subroutine tfgh()
+ integer :: i(2)
+ DATA i/(i, i=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+ do i = 1, 5 ! { dg-error "cannot be a sub-component" }
+ end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh
+
+subroutine tfgh2()
+ integer, save :: x[*]
+ integer :: i(2)
+ DATA i/(x, x=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
+ do x = 1, 5 ! { dg-error "cannot be a coarray" }
+ end do ! { dg-error "Expecting END SUBROUTINE" }
+end subroutine tfgh2
+
+
+subroutine f4f4()
+ type t
+ procedure(), pointer, nopass :: ppt => null()
+ end type t
+ external foo
+ type(t), save :: x[*]
+ x%ppt => foo
+ x[1]%ppt => foo ! { dg-error "shall not have a coindex" }
+end subroutine f4f4
+
+
+subroutine corank()
+ integer, allocatable :: a[:,:]
+ call one(a) ! OK
+ call two(a) ! { dg-error "Corank mismatch in argument" }
+contains
+ subroutine one(x)
+ integer :: x[*]
+ end subroutine one
+ subroutine two(x)
+ integer, allocatable :: x[:]
+ end subroutine two
+end subroutine corank
+
+subroutine assign42()
+ integer, allocatable :: z(:)[:]
+ z(:)[1] = z
+end subroutine assign42
+
+! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } }