re PR fortran/91443 (-Wargument-mismatch does not catch mismatch for global procedure)
2019-08-15 Thomas Koenig <tkoenig@gcc.gnu.org> 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 <tkoenig@gcc.gnu.org> 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
This commit is contained in:
Thomas Koenig
parent
7148dede8a
commit
fb078366c7
15 changed files with 202 additions and 41 deletions
|
|
@ -1,3 +1,21 @@
|
|||
2019-08-15 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
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 <kargl@gcc.gnu.org>
|
||||
|
||||
PR fortran/87991
|
||||
|
|
@ -7,7 +25,7 @@
|
|||
2019-08-13 Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
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 <tkoenig@gcc.gnu.org>
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,17 @@
|
|||
2019-08-15 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
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 <rguenther@suse.de>
|
||||
|
||||
PR tree-optimization/91445
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
18
gcc/testsuite/gfortran.dg/argument_checking_19.f90
Normal file
18
gcc/testsuite/gfortran.dg/argument_checking_19.f90
Normal file
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 <jvdelisle@gcc.gnu.org>
|
||||
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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue