diff options
| -rw-r--r-- | gcc/fortran/frontend-passes.c | 65 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/error_recovery_1.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/interface_47.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/use_15.f90 | 2 |
6 files changed, 87 insertions, 12 deletions
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index d5d71b5..69f9ca6 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -5493,26 +5493,75 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, return check_externals_procedure (sym, loc, actual); } -/* Called routine. */ +/* Function to check if any interface clashes with a global + identifier, to be invoked via gfc_traverse_ns. */ -void -gfc_check_externals (gfc_namespace *ns) +static void +check_against_globals (gfc_symbol *sym) { + gfc_gsymbol *gsym; + gfc_symbol *def_sym = NULL; + const char *sym_name; + char buf [200]; - gfc_clear_error (); + if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE + || sym->attr.generic || sym->error) + return; - /* Turn errors into warnings if the user indicated this. */ + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; - if (!pedantic && flag_allow_argument_mismatch) - gfc_errors_to_warnings (true); + gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name); + if (gsym && gsym->ns) + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (!def_sym || def_sym->error || def_sym->attr.generic) + return; + + buf[0] = 0; + gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf), + NULL, NULL, NULL); + if (buf[0] != 0) + { + gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at, + &sym->declared_at); + sym->error = 1; + def_sym->error = 1; + } + +} + +/* Do the code-walkling part for gfc_check_externals. */ +static void +gfc_check_externals0 (gfc_namespace *ns) +{ gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); for (ns = ns->contained; ns; ns = ns->sibling) { if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - gfc_check_externals (ns); + gfc_check_externals0 (ns); } +} + +/* Called routine. */ + +void gfc_check_externals (gfc_namespace *ns) +{ + gfc_clear_error (); + + /* Turn errors into warnings if the user indicated this. */ + + if (!pedantic && flag_allow_argument_mismatch) + gfc_errors_to_warnings (true); + + gfc_check_externals0 (ns); + gfc_traverse_ns (ns, check_against_globals); + gfc_errors_to_warnings (false); } + diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5cc9f72..9c178d0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2634,6 +2634,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) gfc_error ("Interface mismatch in global procedure %qs at %L: %s", sym->name, &sym->declared_at, reason); + sym->error = 1; gfc_errors_to_warnings (false); goto done; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 96e4cee..abd3b5c 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -3145,18 +3145,24 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) } -/* Generate an error if a symbol is ambiguous. */ +/* Generate an error if a symbol is ambiguous, and set the error flag + on it. */ static void ambiguous_symbol (const char *name, gfc_symtree *st) { + if (st->n.sym->error) + return; + if (st->n.sym->module) gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from module %qs", name, st->n.sym->name, st->n.sym->module); else gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from current program unit", name, st->n.sym->name); + + st->n.sym->error = 1; } diff --git a/gcc/testsuite/gfortran.dg/error_recovery_1.f90 b/gcc/testsuite/gfortran.dg/error_recovery_1.f90 index 7f19ab5..9e2540c 100644 --- a/gcc/testsuite/gfortran.dg/error_recovery_1.f90 +++ b/gcc/testsuite/gfortran.dg/error_recovery_1.f90 @@ -2,14 +2,14 @@ ! PR fortran/24549 (and duplicate PR fortran/27487) module gfcbug29_import interface - subroutine foo (x) + subroutine foo (x) ! { dg-warning "wrong number of arguments" } something :: dp ! { dg-error "Unclassifiable statement" } real (kind=dp) :: x ! { dg-error "has not been declared or is a variable, which does not reduce to a constant expression" } end subroutine foo end interface end module gfcbug29_import -subroutine FOO +subroutine FOO ! { dg-warning "wrong number of arguments" } X :: I equivalence (I,I) end diff --git a/gcc/testsuite/gfortran.dg/interface_47.f90 b/gcc/testsuite/gfortran.dg/interface_47.f90 new file mode 100644 index 0000000..6f1d1a7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_47.f90 @@ -0,0 +1,19 @@ +! PR fortran/27318 +! { dg-do compile } +! This tests for mismatch between the interface for a global +! procedure and the procedure itself. + +module test +implicit none +interface + subroutine hello(n) ! { dg-warning "INTENT mismatch" } + integer :: n + end subroutine hello +end interface +end module test + +subroutine hello(n) ! { dg-warning "INTENT mismatch" } + integer, intent(in) :: n + integer :: i + do i = 1,n; print *, 'hello'; end do +end subroutine hello diff --git a/gcc/testsuite/gfortran.dg/use_15.f90 b/gcc/testsuite/gfortran.dg/use_15.f90 index eb5aa87..9722db4 100644 --- a/gcc/testsuite/gfortran.dg/use_15.f90 +++ b/gcc/testsuite/gfortran.dg/use_15.f90 @@ -34,4 +34,4 @@ subroutine my_sub3 (a) ! { dg-error "\(1\)" } print *, a end subroutine -END +END ! { dg-error "is an ambiguous reference" } |