From fb078366c749168c86a97df8423eb0b8f2c948b2 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Thu, 15 Aug 2019 22:52:40 +0000 Subject: [PATCH] re PR fortran/91443 (-Wargument-mismatch does not catch mismatch for global procedure) 2019-08-15 Thomas Koenig PR fortran/91443 * frontend-passes.c (check_externals_expr): New function. (check_externals_code): New function. (gfc_check_externals): New function. * gfortran.h (debug): Add prototypes for gfc_symbol * and gfc_expr *. (gfc_check_externals): Add prototype. * interface.c (compare_actual_formal): Do not complain about alternate returns if the formal argument is optional. (gfc_procedure_use): Handle cases when an error has been issued previously. Break long line. * parse.c (gfc_parse_file): Call gfc_check_externals for all external procedures. * resolve.c (resolve_global_procedure): Remove checking of argument list. 2019-08-15 Thomas Koenig PR fortran/91443 * gfortran.dg/argument_checking_19.f90: New test. * gfortran.dg/altreturn_10.f90: Change dg-warning to dg-error. * gfortran.dg/dec_union_11.f90: Add -std=legacy. * gfortran.dg/hollerith8.f90: Likewise. Remove warning for Hollerith constant. * gfortran.dg/integer_exponentiation_2.f90: New subroutine gee_i8; use it to avoid type mismatches. * gfortran.dg/pr41011.f: Add -std=legacy. * gfortran.dg/whole_file_1.f90: Change warnings to errors. * gfortran.dg/whole_file_2.f90: Likewise. From-SVN: r274551 --- gcc/fortran/ChangeLog | 20 +++- gcc/fortran/frontend-passes.c | 98 ++++++++++++++++++- gcc/fortran/gfortran.h | 3 + gcc/fortran/interface.c | 24 ++++- gcc/fortran/parse.c | 6 ++ gcc/fortran/resolve.c | 16 +-- gcc/testsuite/ChangeLog | 14 +++ gcc/testsuite/gfortran.dg/altreturn_10.f90 | 2 +- .../gfortran.dg/argument_checking_19.f90 | 18 ++++ gcc/testsuite/gfortran.dg/dec_union_11.f90 | 2 +- gcc/testsuite/gfortran.dg/hollerith8.f90 | 6 +- .../gfortran.dg/integer_exponentiation_2.f90 | 24 +++-- gcc/testsuite/gfortran.dg/pr41011.f | 2 +- gcc/testsuite/gfortran.dg/whole_file_1.f90 | 4 +- gcc/testsuite/gfortran.dg/whole_file_2.f90 | 4 +- 15 files changed, 202 insertions(+), 41 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_19.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 42cf2f57947..3ddb00728a5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2019-08-15 Thomas Koenig + + PR fortran/91443 + * frontend-passes.c (check_externals_expr): New function. + (check_externals_code): New function. + (gfc_check_externals): New function. + * gfortran.h (debug): Add prototypes for gfc_symbol * and + gfc_expr *. + (gfc_check_externals): Add prototype. + * interface.c (compare_actual_formal): Do not complain about + alternate returns if the formal argument is optional. + (gfc_procedure_use): Handle cases when an error has been issued + previously. Break long line. + * parse.c (gfc_parse_file): Call gfc_check_externals for all + external procedures. + * resolve.c (resolve_global_procedure): Remove checking of + argument list. + 2019-08-13 Steven G. Kargl PR fortran/87991 @@ -7,7 +25,7 @@ 2019-08-13 Steven G. Kargl PR fortran/88072 - * misc.c (gfc_typename): Do not point to something that ought not to + * misc.c (gfc_typename): Do not point to something that ought not to be pointed at. 2013-08-13 Thomas Koenig diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index be99a06c3fc..dd820899b02 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -56,7 +56,6 @@ static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, static int call_external_blas (gfc_code **, int *, void *); static int matmul_temp_args (gfc_code **, int *,void *data); static int index_interchange (gfc_code **, int*, void *); - static bool is_fe_temp (gfc_expr *e); #ifdef CHECKING_P @@ -5364,3 +5363,100 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, } return 0; } + +/* As a post-resolution step, check that all global symbols which are + not declared in the source file match in their call signatures. + We do this by looping over the code (and expressions). The first call + we happen to find is assumed to be canonical. */ + +/* Callback for external functions. */ + +static int +check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *e = *ep; + gfc_symbol *sym, *def_sym; + gfc_gsymbol *gsym; + + if (e->expr_type != EXPR_FUNCTION) + return 0; + + sym = e->value.function.esym; + + if (sym == NULL || sym->attr.is_bind_c) + return 0; + + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + return 0; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym == NULL) + return 0; + + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (sym && def_sym) + gfc_procedure_use (def_sym, &e->value.function.actual, &e->where); + + return 0; +} + +/* Callback for external code. */ + +static int +check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_symbol *sym, *def_sym; + gfc_gsymbol *gsym; + + if (co->op != EXEC_CALL) + return 0; + + sym = co->resolved_sym; + if (sym == NULL || sym->attr.is_bind_c) + return 0; + + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + return 0; + + if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) + return 0; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym == NULL) + return 0; + + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (sym && def_sym) + gfc_procedure_use (def_sym, &co->ext.actual, &co->loc); + + return 0; +} + +/* Called routine. */ + +void +gfc_check_externals (gfc_namespace *ns) +{ + + gfc_clear_error (); + + /* Turn errors into warnings if -std=legacy is given by the user. */ + + if (!pedantic && !(gfc_option.warn_std & GFC_STD_LEGACY)) + gfc_errors_to_warnings (true); + + 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_errors_to_warnings (false); +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 75e5b2f0644..8a0e8b3f119 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3477,6 +3477,8 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *); void gfc_dump_c_prototypes (gfc_namespace *, FILE *); void gfc_dump_external_c_prototypes (FILE *); void gfc_dump_global_symbols (FILE *); +void debug (gfc_symbol *); +void debug (gfc_expr *); /* parse.c */ bool gfc_parse_file (void); @@ -3551,6 +3553,7 @@ int gfc_dummy_code_callback (gfc_code **, int *, void *); int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); bool gfc_has_dimen_vector_ref (gfc_expr *e); +void gfc_check_externals (gfc_namespace *); /* simplify.c */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 1d14f83057e..d6f6cce4fbf 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -2979,10 +2979,15 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (a->expr == NULL) { - if (where) - gfc_error_now ("Unexpected alternate return specifier in " - "subroutine call at %L", where); - return false; + if (f->sym->attr.optional) + continue; + else + { + if (where) + gfc_error_now ("Unexpected alternate return specifier in " + "subroutine call at %L", where); + return false; + } } /* Make sure that intrinsic vtables exist for calls to unlimited @@ -3723,6 +3728,9 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) for (a = *ap; a; a = a->next) { + if (a->expr && a->expr->error) + return false; + /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ if (a->name != NULL && a->name[0] != '%') { @@ -3738,6 +3746,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error ("Assumed-type argument %s at %L requires an explicit " "interface", a->expr->symtree->n.sym->name, &a->expr->where); + a->expr->error = 1; break; } @@ -3751,6 +3760,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " "component at %L requires an explicit interface for " "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; break; } @@ -3764,13 +3774,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " "component at %L requires an explicit interface for " "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; break; } if (a->expr && a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) { - gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); + gfc_error ("MOLD argument to NULL required at %L", + &a->expr->where); + a->expr->error = 1; return false; } @@ -3780,6 +3793,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { gfc_error ("Assumed-rank argument requires an explicit interface " "at %L", &a->expr->where); + a->expr->error = 1; return false; } } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 66d84b4118f..31466d296ad 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -6319,6 +6319,12 @@ done: /* Do the resolution. */ resolve_all_program_units (gfc_global_ns_list); + + /* Fixup for external procedures. */ + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + gfc_check_externals (gfc_current_ns); + /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ac9192ae02c..1f48045d8fe 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2506,8 +2506,7 @@ gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) static void -resolve_global_procedure (gfc_symbol *sym, locus *where, - gfc_actual_arglist **actual, int sub) +resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) { gfc_gsymbol * gsym; gfc_namespace *ns; @@ -2615,14 +2614,6 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, " %s", sym->name, &sym->declared_at, reason); goto done; } - - if (!pedantic - || ((gfc_option.warn_std & GFC_STD_LEGACY) - && !(gfc_option.warn_std & GFC_STD_GNU))) - gfc_errors_to_warnings (true); - - if (sym->attr.if_source != IFSRC_IFBODY) - gfc_procedure_use (def_sym, actual, where); } done: @@ -3198,8 +3189,7 @@ resolve_function (gfc_expr *expr) /* If the procedure is external, check for usage. */ if (sym && is_external_proc (sym)) - resolve_global_procedure (sym, &expr->where, - &expr->value.function.actual, 0); + resolve_global_procedure (sym, &expr->where, 0); if (sym && sym->ts.type == BT_CHARACTER && sym->ts.u.cl @@ -3675,7 +3665,7 @@ resolve_call (gfc_code *c) /* If external, check for usage. */ if (csym && is_external_proc (csym)) - resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1); + resolve_global_procedure (csym, &c->loc, 1); t = true; if (c->resolved_sym == NULL) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a21600b4cc9..aeaaac0a4a5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2019-08-15 Thomas Koenig + + PR fortran/91443 + * gfortran.dg/argument_checking_19.f90: New test. + * gfortran.dg/altreturn_10.f90: Change dg-warning to dg-error. + * gfortran.dg/dec_union_11.f90: Add -std=legacy. + * gfortran.dg/hollerith8.f90: Likewise. Remove warning for + Hollerith constant. + * gfortran.dg/integer_exponentiation_2.f90: New subroutine gee_i8; + use it to avoid type mismatches. + * gfortran.dg/pr41011.f: Add -std=legacy. + * gfortran.dg/whole_file_1.f90: Change warnings to errors. + * gfortran.dg/whole_file_2.f90: Likewise. + 2019-08-15 Richard Biener PR tree-optimization/91445 diff --git a/gcc/testsuite/gfortran.dg/altreturn_10.f90 b/gcc/testsuite/gfortran.dg/altreturn_10.f90 index 7e5d56977ea..a388c3c714f 100644 --- a/gcc/testsuite/gfortran.dg/altreturn_10.f90 +++ b/gcc/testsuite/gfortran.dg/altreturn_10.f90 @@ -14,6 +14,6 @@ subroutine sub (x) end subroutine sub2 call sub (*99) ! { dg-error "Unexpected alternate return specifier" } - call sub (99.) ! { dg-warning "Type mismatch in argument" } + call sub (99.) ! { dg-error "Type mismatch in argument" } 99 stop end diff --git a/gcc/testsuite/gfortran.dg/argument_checking_19.f90 b/gcc/testsuite/gfortran.dg/argument_checking_19.f90 new file mode 100644 index 00000000000..4460226831e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_19.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 91443 - this was not caught. +module x +contains + subroutine a + call foo(1) ! { dg-error "Type mismatch in argument" } + end subroutine a +end module x + +subroutine foo(a) + real :: a + print *,a +end subroutine foo + +program main + use x + call a +end program main diff --git a/gcc/testsuite/gfortran.dg/dec_union_11.f90 b/gcc/testsuite/gfortran.dg/dec_union_11.f90 index 3ff4b49b62f..41e23b267ef 100644 --- a/gcc/testsuite/gfortran.dg/dec_union_11.f90 +++ b/gcc/testsuite/gfortran.dg/dec_union_11.f90 @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-g -fdec-structure" } +! { dg-options "-g -fdec-structure -std=legacy" } ! ! Test a regression where typespecs of unions containing character buffers of ! different lengths where copied, resulting in a bad gimple tree state. diff --git a/gcc/testsuite/gfortran.dg/hollerith8.f90 b/gcc/testsuite/gfortran.dg/hollerith8.f90 index b9f25d05a71..384904d4e6c 100644 --- a/gcc/testsuite/gfortran.dg/hollerith8.f90 +++ b/gcc/testsuite/gfortran.dg/hollerith8.f90 @@ -1,9 +1,9 @@ ! { dg-do run } -! { dg-options "-std=gnu" } +! { dg-options "-std=legacy" } ! PR43217 Output of Hollerith constants which are not a multiple of 4 bytes ! Test case prepared from OP by Jerry DeLisle program hello2 - call wrtout (9hHELLO YOU, 9) + call wrtout (9hHELLO YOU, 9) ! { dg-warning "Rank mismatch" } stop end @@ -22,5 +22,3 @@ subroutine wrtout (iarray, nchrs) & outstr.ne."48454C4C 4F20594F 55202020") STOP 1 return end -! { dg-warning "Hollerith constant" "" { target *-*-* } 6 } -! { dg-warning "Rank mismatch" "" { target *-*-* } 6 } diff --git a/gcc/testsuite/gfortran.dg/integer_exponentiation_2.f90 b/gcc/testsuite/gfortran.dg/integer_exponentiation_2.f90 index 41f4cbfc64c..ec018ff43ef 100644 --- a/gcc/testsuite/gfortran.dg/integer_exponentiation_2.f90 +++ b/gcc/testsuite/gfortran.dg/integer_exponentiation_2.f90 @@ -139,16 +139,16 @@ subroutine foo(a) call gee_i(i**(-huge(0_4))) call gee_i(i**(-huge(0_4)-1_4)) - call gee_i(i**0_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**1_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**2_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**3_8) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-1_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-2_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-3_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**huge(0_8)) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-huge(0_8))) ! { dg-warning "Type mismatch in argument" } - call gee_i(i**(-huge(0_8)-1_8)) ! { dg-warning "Type mismatch in argument" } + call gee_i8(i**0_8) + call gee_i8(i**1_8) + call gee_i8(i**2_8) + call gee_i8(i**3_8) + call gee_i8(i**(-1_8)) + call gee_i8(i**(-2_8)) + call gee_i8(i**(-3_8)) + call gee_i8(i**huge(0_8)) + call gee_i8(i**(-huge(0_8))) + call gee_i8(i**(-huge(0_8)-1_8)) ! Real call gee_r(a**0_1) @@ -245,6 +245,10 @@ subroutine gee_i(i) integer :: i end subroutine gee_i +subroutine gee_i8(i) + integer(kind=8) :: i +end subroutine gee_i8 + subroutine gee_r(r) real :: r end subroutine gee_r diff --git a/gcc/testsuite/gfortran.dg/pr41011.f b/gcc/testsuite/gfortran.dg/pr41011.f index 83e85fb002a..5a3218581d3 100644 --- a/gcc/testsuite/gfortran.dg/pr41011.f +++ b/gcc/testsuite/gfortran.dg/pr41011.f @@ -1,5 +1,5 @@ ! { dg-do compile } -! { dg-options "-O3" } +! { dg-options "-O3 -std=legacy" } CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch" } *ITY,ISH,NSMT,F) CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA, diff --git a/gcc/testsuite/gfortran.dg/whole_file_1.f90 b/gcc/testsuite/gfortran.dg/whole_file_1.f90 index bceb250970f..c865395fcaa 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_1.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_1.f90 @@ -19,7 +19,7 @@ subroutine b integer :: u1 end type type (u) :: q - call a(q) ! { dg-warning "Type mismatch" } + call a(q) ! { dg-error "Type mismatch" } print *, q%u1 end subroutine @@ -36,7 +36,7 @@ subroutine d integer :: u1 end type type (u) :: q - call c(q) ! { dg-warning "Type mismatch" } + call c(q) ! { dg-error "Type mismatch" } print *, q%u1 end subroutine diff --git a/gcc/testsuite/gfortran.dg/whole_file_2.f90 b/gcc/testsuite/gfortran.dg/whole_file_2.f90 index 60163f42c30..0d445746178 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_2.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_2.f90 @@ -14,8 +14,8 @@ end function program gg real :: h character (5) :: chr = 'hello' -h = a(); ! { dg-warning "Missing actual argument" } -call test ([chr]) ! { dg-warning "Rank mismatch" } +h = a(); ! { dg-error "Missing actual argument" } +call test ([chr]) ! { dg-error "Rank mismatch" } end program gg subroutine test (a) -- 2.30.2