From 6de7294fd4a37431a5c9df578feca6fece431077 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 14 May 2009 11:41:41 +0200 Subject: [PATCH] re PR fortran/39996 (Double typing of function results not detected) 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 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. From-SVN: r147528 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/decl.c | 17 ++++----- gcc/fortran/symbol.c | 31 ++++++++--------- gcc/testsuite/ChangeLog | 7 ++++ gcc/testsuite/gfortran.dg/duplicate_type_2.f90 | 6 ++-- gcc/testsuite/gfortran.dg/duplicate_type_3.f90 | 48 ++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/func_decl_2.f90 | 6 ++-- 7 files changed, 90 insertions(+), 33 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index db5f373..c768fed 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 7aa550e..6c6fa45 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 2160afa..67240ad 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 28ed5fc..f22bcce 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 5b86dc6..0fd9258 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 0000000..802029d --- /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 c2cc440..658883e 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 -- 2.7.4