diff options
| author | Tobias Burnus <burnus@net-b.de> | 2012-07-19 19:39:49 +0200 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2012-07-19 19:39:49 +0200 |
| commit | 99091b70396fb846ec17a996a658516707ddfef9 (patch) | |
| tree | 13e0d6aed459df9c9ef59b67865660db90c60905 | |
| parent | 638eeae8042febc7cf5b01b9330558543e874f58 (diff) | |
| download | gcc-99091b70396fb846ec17a996a658516707ddfef9.zip gcc-99091b70396fb846ec17a996a658516707ddfef9.tar.gz gcc-99091b70396fb846ec17a996a658516707ddfef9.tar.bz2 | |
interface.c (compare_parameter, [...]): Fix handling of polymorphic arguments.
2012-07-19 Tobias Burnus <burnus@net-b.de>
* interface.c (compare_parameter, compare_actual_formal): Fix
handling of polymorphic arguments.
From-SVN: r189669
| -rw-r--r-- | gcc/fortran/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 22 |
2 files changed, 21 insertions, 6 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0f5e403..3d6bf6d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2012-07-19 Tobias Burnus <burnus@net-b.de> + + * interface.c (compare_parameter, compare_actual_formal): Fix + handling of polymorphic arguments. + 2012-07-17 Janus Weil <janus@gcc.gnu.org> PR fortran/51081 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 922de03..2e181c9 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1743,7 +1743,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } /* F2008, 12.5.2.5; IR F08/0073. */ - if (formal->ts.type == BT_CLASS + if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL && ((CLASS_DATA (formal)->attr.class_pointer && !formal->attr.intent == INTENT_IN) || CLASS_DATA (formal)->attr.allocatable)) @@ -2289,11 +2289,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } - if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer - && (f->sym->attr.allocatable || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)) - { - if (where && (f->sym->attr.allocatable || !f->sym->attr.optional)) + if (a->expr->expr_type == EXPR_NULL + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer + && (f->sym->attr.allocatable || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + || (f->sym->ts.type == BT_CLASS + && !CLASS_DATA (f->sym)->attr.class_pointer + && (CLASS_DATA (f->sym)->attr.allocatable + || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) + { + if (where + && (!f->sym->attr.optional + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable))) gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", where, f->sym->name); else if (where) |