diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 67 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 52 |
4 files changed, 91 insertions, 35 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b3019f3..bf91112 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b8eb555..e5394b8 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index eb01b0e..acb5400 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index dcf6c4e..482a75e 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1557,47 +1557,26 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } } - if (formal->attr.codimension) + if (formal->attr.codimension && !gfc_is_coarray (actual)) { - 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", + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray", formal->name, &actual->where); - return 0; - } + 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; - } + if (formal->attr.codimension && formal->attr.allocatable) + { + gfc_ref *last = NULL; 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 |