OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

expr.c (gfc_is_coarray): New function. 

2011-07-19  Tobias Burnus  <burnus@net-b.de>

        * expr.c (gfc_is_coarray): New function.
        * gfortran.h (gfc_is_coarray): New prototype.
        * interface.c (compare_parameter): Use it.

2011-07-19  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_args_1.f90: New.
        * gfortran.dg/coarray_args_2.f90: New.

From-SVN: r176467
This commit is contained in:
Tobias Burnus 2011-07-19 18:46:02 +02:00 committed by Tobias Burnus
parent 9dafd06325
commit 394d3a2e8d
7 changed files with 167 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2011-07-19 Tobias Burnus <burnus@net-b.de>
* expr.c (gfc_is_coarray): New function.
* gfortran.h (gfc_is_coarray): New prototype.
* interface.c (compare_parameter): Use it.
2011-07-19 Richard Guenther <rguenther@suse.de>
* trans-expr.c (fill_with_spaces): Use fold_build_pointer_plus.

67
gcc/fortran/expr.c
View File

@ -4154,6 +4154,73 @@ gfc_is_coindexed (gfc_expr *e)
}
/* Coarrays are variables with a corank but not being coindexed. However, also
the following is a coarray: A subobject of a coarray is a coarray if it does
not have any cosubscripts, vector subscripts, allocatable component
selection, or pointer component selection. (F2008, 2.4.7) */
bool
gfc_is_coarray (gfc_expr *e)
{
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *comp;
bool coindexed;
bool coarray;
int i;
if (e->expr_type != EXPR_VARIABLE)
return false;
coindexed = false;
sym = e->symtree->n.sym;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
coarray = CLASS_DATA (sym)->attr.codimension;
else
coarray = sym->attr.codimension;
for (ref = e->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_COMPONENT:
comp = ref->u.c.component;
if (comp->attr.pointer || comp->attr.allocatable)
{
coindexed = false;
if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
coarray = CLASS_DATA (comp)->attr.codimension;
else
coarray = comp->attr.codimension;
}
break;
case REF_ARRAY:
if (!coarray)
break;
if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
{
coindexed = true;
break;
}
for (i = 0; i < ref->u.ar.dimen; i++)
if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
{
coarray = false;
break;
}
break;
case REF_SUBSTRING:
break;
}
return coarray && !coindexed;
}
int
gfc_get_corank (gfc_expr *e)
{

1
gcc/fortran/gfortran.h
View File

@ -2735,6 +2735,7 @@ bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);
bool gfc_is_coarray (gfc_expr *);
int gfc_get_corank (gfc_expr *);
bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);

54
gcc/fortran/interface.c
View File

@ -1557,47 +1557,26 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
}
if (formal->attr.codimension)
if (formal->attr.codimension && !gfc_is_coarray (actual))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be a coarray",
formal->name, &actual->where);
return 0;
}
if (formal->attr.codimension && formal->attr.allocatable)
{
gfc_ref *last = NULL;
if (actual->expr_type != EXPR_VARIABLE
|| !gfc_expr_attr (actual).codimension)
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be a coarray",
formal->name, &actual->where);
return 0;
}
if (gfc_is_coindexed (actual))
{
if (where)
gfc_error ("Actual argument to '%s' at %L must be a coarray "
"and not coindexed", formal->name, &actual->where);
return 0;
}
for (ref = actual->ref; ref; ref = ref->next)
{
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 (ref->type == REF_COMPONENT)
last = ref;
/* 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 ((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)",
@ -1606,7 +1585,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
: actual->symtree->n.sym->as->corank);
return 0;
}
}
if (formal->attr.codimension)
{
/* F2008, 12.5.2.8. */
if (formal->attr.dimension
&& (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
@ -1633,7 +1615,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
}
}
/* F2008, C1239/C1240. */
if (actual->expr_type == EXPR_VARIABLE

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2011-07-19 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_args_1.f90: New.
* gfortran.dg/coarray_args_2.f90: New.
2011-07-19 Janus Weil <janus@gcc.gnu.org>
PR fortran/49708

20
gcc/testsuite/gfortran.dg/coarray_args_1.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Argument checking
!
implicit none
type t
integer :: i
integer,allocatable :: j
end type t
type(t), save :: x[*]
call sub1(x%i)
call sub1(x[1]%i) ! { dg-error "must be a coarray" }
contains
subroutine sub1(y)
integer :: y[*]
end subroutine sub1
end

50
gcc/testsuite/gfortran.dg/coarray_args_2.f90 Normal file
View File

@ -0,0 +1,50 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Check argument passing.
! Taken from Reinhold Bader's fortran_tests.
!
module mod_rank_mismatch_02
implicit none
integer, parameter :: ndim = 2
contains
subroutine subr(n,w)
integer :: n
real :: w(n,*)[*]
integer :: k, x
if (this_image() == 0) then
x = 1.0
do k = 1, num_images()
if (abs(w(2,1)[k] - x) > 1.0e-5) then
write(*, *) 'FAIL'
error stop
end if
x = x + 1.0
end do
end if
end subroutine
end module
program rank_mismatch_02
use mod_rank_mismatch_02
implicit none
real :: a(ndim,2)[*]
a = 0.0
a(2,2) = 1.0 * this_image()
sync all
call subr(ndim, a(1:1,2)) ! OK
call subr(ndim, a(1,2)) ! { dg-error "must be simply contiguous" }
! See also F08/0048 and PR 45859 about the validity
if (this_image() == 1) then
write(*, *) 'OK'
end if
end program
! { dg-final { cleanup-modules "mod_rank_mismatch_02" } }