From 99091b70396fb846ec17a996a658516707ddfef9 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Thu, 19 Jul 2012 19:39:49 +0200 Subject: [PATCH] interface.c (compare_parameter, [...]): Fix handling of polymorphic arguments. 2012-07-19 Tobias Burnus * interface.c (compare_parameter, compare_actual_formal): Fix handling of polymorphic arguments. From-SVN: r189669 --- gcc/fortran/ChangeLog | 5 +++++ gcc/fortran/interface.c | 22 ++++++++++++++++------ 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0f5e403ceaa..3d6bf6dce96 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2012-07-19 Tobias Burnus + + * interface.c (compare_parameter, compare_actual_formal): Fix + handling of polymorphic arguments. + 2012-07-17 Janus Weil PR fortran/51081 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 922de039c2d..2e181c9be87 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) -- 2.30.2