diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index db5f3731722..c768fed0f96 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-05-14 Janus Weil + + PR fortran/39996 + * decl.c (gfc_match_function_decl): Use gfc_add_type. + * symbol.c (gfc_add_type): Better checking for duplicate types in + function declarations. And: Always give an error for duplicte types, + not just a warning with -std=gnu. + 2009-05-14 Jakub Jelinek PR fortran/39865 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 7aa550ebd8e..6c6fa45a8c6 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4708,14 +4708,6 @@ gfc_match_function_decl (void) || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) goto cleanup; - if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN - && !sym->attr.implicit_type) - { - gfc_error ("Function '%s' at %C already has a type of %s", name, - gfc_basic_typename (sym->ts.type)); - goto cleanup; - } - /* Delay matching the function characteristics until after the specification block by signalling kind=-1. */ sym->declared_at = old_loc; @@ -4726,12 +4718,17 @@ gfc_match_function_decl (void) if (result == NULL) { - sym->ts = current_ts; + if (current_ts.type != BT_UNKNOWN + && gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE) + goto cleanup; sym->result = sym; } else { - result->ts = current_ts; + if (current_ts.type != BT_UNKNOWN + && gfc_add_type (result, ¤t_ts, &gfc_current_locus) + == FAILURE) + goto cleanup; sym->result = result; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 2160afa14c0..67240ad6a0f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1559,31 +1559,30 @@ gfc_try gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) { sym_flavor flavor; + bt type; if (where == NULL) where = &gfc_current_locus; - if (sym->ts.type != BT_UNKNOWN) + if (sym->result) + type = sym->result->ts.type; + else + type = sym->ts.type; + + if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) + type = sym->ns->proc_name->ts.type; + + if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)) { - const char *msg = "Symbol '%s' at %L already has basic type of %s"; - if (!(sym->ts.type == ts->type && sym->attr.result) - || gfc_notification_std (GFC_STD_GNU) == ERROR - || pedantic) - { - gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type)); - return FAILURE; - } - if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where, - gfc_basic_typename (sym->ts.type)) == FAILURE) - return FAILURE; - if (gfc_option.warn_surprising) - gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type)); + gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, + where, gfc_basic_typename (type)); + return FAILURE; } if (sym->attr.procedure && sym->ts.interface) { - gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where, - gfc_basic_typename (ts->type)); + gfc_error ("Procedure '%s' at %L may not have basic type of %s", + sym->name, where, gfc_basic_typename (ts->type)); return FAILURE; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 28ed5fc3d4d..f22bcceed3f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-05-14 Janus Weil + + PR fortran/39996 + * gfortran.dg/func_decl_2.f90: Modified (replacing warnings by errors). + * gfortran.dg/duplicate_type_2.f90: Ditto. + * gfortran.dg/duplicate_type_3.f90: New. + 2009-05-14 Laurent GUERBY * ada/acats/tests/c3/c38202a.ada: Use Impdef. diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_2.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_2.f90 index 5b86dc6e775..0fd9258fe80 100644 --- a/gcc/testsuite/gfortran.dg/duplicate_type_2.f90 +++ b/gcc/testsuite/gfortran.dg/duplicate_type_2.f90 @@ -7,14 +7,14 @@ INTEGER FUNCTION foo () IMPLICIT NONE - INTEGER :: foo ! { dg-warning "basic type of" } - INTEGER :: foo ! { dg-warning "basic type of" } + INTEGER :: foo ! { dg-error "basic type of" } + INTEGER :: foo ! { dg-error "basic type of" } foo = 42 END FUNCTION foo INTEGER FUNCTION bar () RESULT (x) IMPLICIT NONE - INTEGER :: x ! { dg-warning "basic type of" } + INTEGER :: x ! { dg-error "basic type of" } INTEGER :: y INTEGER :: y ! { dg-error "basic type of" } diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_3.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_3.f90 new file mode 100644 index 00000000000..802029db0ca --- /dev/null +++ b/gcc/testsuite/gfortran.dg/duplicate_type_3.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR 39996: Double typing of function results not detected +! +! Contributed by Janus Weil + + interface + real function A () + end function + end interface + real :: A ! { dg-error "already has basic type of" } + + real :: B + interface + real function B () ! { dg-error "already has basic type of" } + end function ! { dg-error "Expecting END INTERFACE statement" } + end interface + + interface + function C () + real :: C + end function + end interface + real :: C ! { dg-error "already has basic type of" } + + real :: D + interface + function D () + real :: D ! { dg-error "already has basic type of" } + end function + end interface + + interface + function E () result (s) + real ::s + end function + end interface + real :: E ! { dg-error "already has basic type of" } + + real :: F + interface + function F () result (s) + real ::s ! { dg-error "already has basic type of" } + end function F + end interface + +end + diff --git a/gcc/testsuite/gfortran.dg/func_decl_2.f90 b/gcc/testsuite/gfortran.dg/func_decl_2.f90 index c2cc4403cd6..658883e65e2 100644 --- a/gcc/testsuite/gfortran.dg/func_decl_2.f90 +++ b/gcc/testsuite/gfortran.dg/func_decl_2.f90 @@ -1,8 +1,6 @@ ! { dg-do compile } ! Test fix for PR16943 in which the double typing of -! N caused an error. This is a common extension to the -! F95 standard, so the error is only thrown for -std=f95 -! or -pedantic. +! N caused an error. ! ! Contributed by Paul Thomas ! @@ -14,7 +12,7 @@ integer function bugf(M) result (N) integer, intent (in) :: M - integer :: N ! { dg-warning "already has basic type of INTEGER" } + integer :: N ! { dg-error "already has basic type of INTEGER" } N = M return end function bugf