diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2009-06-21 21:05:35 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2009-06-21 21:05:35 +0200 |
| commit | 9b63f28250377b90a744fe57ff482df9c6ee70ed (patch) | |
| tree | 3160767e4f7c3939cd7b606a23072d4c87d6230b /gcc/fortran/interface.c | |
| parent | 45a1ba933e8a2679470d45feeb440183dcbad4d9 (diff) | |
| download | gcc-9b63f28250377b90a744fe57ff482df9c6ee70ed.zip gcc-9b63f28250377b90a744fe57ff482df9c6ee70ed.tar.gz gcc-9b63f28250377b90a744fe57ff482df9c6ee70ed.tar.bz2 | |
re PR fortran/39850 (Too strict checking for procedures as actual argument)
2009-06-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/39850
* interface.c (gfc_compare_interfaces): Take care of implicit typing
when checking the function attribute. Plus another bugfix.
(compare_parameter): Set attr.function and attr.subroutine according
to the usage of a procedure as actual argument.
2009-06-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/39850
* gfortran.dg/interface_19.f90: Add 'cleanup-modules'.
* gfortran.dg/interface_20.f90: Ditto.
* gfortran.dg/interface_21.f90: Ditto.
* gfortran.dg/interface_22.f90: Ditto.
* gfortran.dg/interface_30.f90: New.
* gfortran.dg/proc_ptr_11.f90: Fix invalid test case.
From-SVN: r148767
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 16 |
1 files changed, 12 insertions, 4 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 4954389..7d26fe4 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -939,7 +939,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, { gfc_formal_arglist *f1, *f2; - if (s1->attr.function && !s2->attr.function) + if (s1->attr.function && (s2->attr.subroutine + || (!s2->attr.function && s2->ts.type == BT_UNKNOWN + && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN))) { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' is not a function", s2->name); @@ -967,8 +969,6 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, "of '%s'", s2->name); return 0; } - if (s1->attr.if_source == IFSRC_DECL) - return 1; } if (s1->attr.if_source == IFSRC_UNKNOWN @@ -1388,6 +1388,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (actual->ts.type == BT_PROCEDURE) { char err[200]; + gfc_symbol *act_sym = actual->symtree->n.sym; if (formal->attr.flavor != FL_PROCEDURE) { @@ -1396,7 +1397,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } - if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1, err, + if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err, sizeof(err))) { if (where) @@ -1405,6 +1406,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (formal->attr.function && !act_sym->attr.function) + gfc_add_function (&act_sym->attr, act_sym->name, &act_sym->declared_at); + + if (formal->attr.subroutine && !act_sym->attr.subroutine) + gfc_add_subroutine (&act_sym->attr, act_sym->name, + &act_sym->declared_at); + return 1; } |