From: Tobias Burnus Date: Tue, 27 Jul 2010 08:44:22 +0000 (+0200) Subject: re PR fortran/40873 (-fwhole-file -fwhole-program: Wrong decls cause too much to... X-Git-Tag: releases/gcc-4.6.0~5413 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=fb55ca75aed99996a52ea22ba5456c918e7e70c6;p=thirdparty%2Fgcc.git re PR fortran/40873 (-fwhole-file -fwhole-program: Wrong decls cause too much to be optimized away) 2010-07-26 Tobias Burnus PR fortran/40873 * trans-decl.c (gfc_get_extern_function_decl): Fix generation for functions which are later in the same file. (gfc_create_function_decl, build_function_decl, build_entry_thunks): Add global argument. * trans.c (gfc_generate_module_code): Update gfc_create_function_decl call. * trans.h (gfc_create_function_decl): Update prototype. * resolve.c (resolve_global_procedure): Also resolve for IFSRC_IFBODY. 2010-07-26 Tobias Burnus PR fortran/40873 * gfortran.dg/whole_file_22.f90: New test. * gfortran.dg/whole_file_23.f90: New test. From-SVN: r162557 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cd8e6e4ed9eb..7700e0bc7d1d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-07-26 Tobias Burnus + + PR fortran/40873 + * trans-decl.c (gfc_get_extern_function_decl): Fix generation + for functions which are later in the same file. + (gfc_create_function_decl, build_function_decl, + build_entry_thunks): Add global argument. + * trans.c (gfc_generate_module_code): Update + gfc_create_function_decl call. + * trans.h (gfc_create_function_decl): Update prototype. + * resolve.c (resolve_global_procedure): Also resolve for + IFSRC_IFBODY. + 2010-07-26 Richard Henderson PR target/44132 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fb9aadc4806a..dab533d82422 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1816,7 +1816,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_global_used (gsym, where); if (gfc_option.flag_whole_file - && sym->attr.if_source == IFSRC_UNKNOWN + && (sym->attr.if_source == IFSRC_UNKNOWN + || sym->attr.if_source == IFSRC_IFBODY) && gsym->type != GSYM_UNKNOWN && gsym->ns && gsym->ns->resolved != -1 @@ -1902,7 +1903,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, gfc_typename (&sym->ts), gfc_typename (&def_sym->ts)); - if (def_sym->formal) + if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY) { gfc_formal_arglist *arg = def_sym->formal; for ( ; arg; arg = arg->next) @@ -1969,14 +1970,19 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, where); /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */ - if (def_sym->result->attr.pointer - || def_sym->result->attr.allocatable) + if ((def_sym->result->attr.pointer + || def_sym->result->attr.allocatable) + && (sym->attr.if_source != IFSRC_IFBODY + || def_sym->result->attr.pointer + != sym->result->attr.pointer + || def_sym->result->attr.allocatable + != sym->result->attr.allocatable)) gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE " "result must have an explicit interface", sym->name, where); /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */ - if (sym->ts.type == BT_CHARACTER + if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY && def_sym->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; @@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */ - if (def_sym->attr.elemental) + if (def_sym->attr.elemental && !sym->attr.elemental) { gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit " "interface", sym->name, &sym->declared_at); } /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */ - if (def_sym->attr.is_bind_c) + if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c) { gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have " "an explicit interface", sym->name, &sym->declared_at); @@ -2010,7 +2016,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, && !(gfc_option.warn_std & GFC_STD_GNU))) gfc_errors_to_warnings (1); - gfc_procedure_use (def_sym, actual, where); + if (sym->attr.if_source != IFSRC_IFBODY) + gfc_procedure_use (def_sym, actual, where); gfc_errors_to_warnings (0); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4a3fcd8c616d..5d6ea02b20e9 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1413,8 +1413,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym) && !sym->backend_decl && gsym && gsym->ns && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) - && gsym->ns->proc_name->backend_decl) + && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) { + if (!gsym->ns->proc_name->backend_decl) + { + /* By construction, the external function cannot be + a contained procedure. */ + locus old_loc; + tree save_fn_decl = current_function_decl; + + current_function_decl = NULL_TREE; + gfc_get_backend_locus (&old_loc); + push_cfun (cfun); + + gfc_create_function_decl (gsym->ns, true); + + pop_cfun (); + gfc_set_backend_locus (&old_loc); + current_function_decl = save_fn_decl; + } + /* If the namespace has entries, the proc_name is the entry master. Find the entry and use its backend_decl. otherwise, use the proc_name backend_decl. */ @@ -1574,7 +1592,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) a master function with alternate entry points. */ static void -build_function_decl (gfc_symbol * sym) +build_function_decl (gfc_symbol * sym, bool global) { tree fndecl, type, attributes; symbol_attribute attr; @@ -1682,7 +1700,11 @@ build_function_decl (gfc_symbol * sym) /* Layout the function declaration and put it in the binding level of the current function. */ - pushdecl (fndecl); + + if (global) + pushdecl_top_level (fndecl); + else + pushdecl (fndecl); sym->backend_decl = fndecl; } @@ -1955,7 +1977,7 @@ trans_function_start (gfc_symbol * sym) /* Create thunks for alternate entry points. */ static void -build_entry_thunks (gfc_namespace * ns) +build_entry_thunks (gfc_namespace * ns, bool global) { gfc_formal_arglist *formal; gfc_formal_arglist *thunk_formal; @@ -1977,7 +1999,7 @@ build_entry_thunks (gfc_namespace * ns) thunk_sym = el->sym; - build_function_decl (thunk_sym); + build_function_decl (thunk_sym, global); create_function_arglist (thunk_sym); trans_function_start (thunk_sym); @@ -2137,17 +2159,18 @@ build_entry_thunks (gfc_namespace * ns) /* Create a decl for a function, and create any thunks for alternate entry - points. */ + points. If global is true, generate the function in the global binding + level, otherwise in the current binding level (which can be global). */ void -gfc_create_function_decl (gfc_namespace * ns) +gfc_create_function_decl (gfc_namespace * ns, bool global) { /* Create a declaration for the master function. */ - build_function_decl (ns->proc_name); + build_function_decl (ns->proc_name, global); /* Compile the entry thunks. */ if (ns->entries) - build_entry_thunks (ns); + build_entry_thunks (ns, global); /* Now create the read argument list. */ create_function_arglist (ns->proc_name); @@ -3728,7 +3751,7 @@ gfc_generate_contained_functions (gfc_namespace * parent) if (ns->parent != parent) continue; - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); } for (ns = parent->contained; ns; ns = ns->sibling) @@ -4364,7 +4387,7 @@ gfc_generate_function_code (gfc_namespace * ns) /* Create the declaration for functions with global scope. */ if (!sym->backend_decl) - gfc_create_function_decl (ns); + gfc_create_function_decl (ns, false); fndecl = sym->backend_decl; old_context = current_function_decl; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 003f6090c2f3..4bd4f3b21983 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1388,7 +1388,7 @@ gfc_generate_module_code (gfc_namespace * ns) if (!n->proc_name) continue; - gfc_create_function_decl (n); + gfc_create_function_decl (n, false); gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE); DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; gfc_module_add_decl (entry, n->proc_name->backend_decl); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 9872e83df9e7..99f0dc09283d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -449,7 +449,7 @@ void gfc_allocate_lang_decl (tree); tree gfc_advance_chain (tree, int); /* Create a decl for a function. */ -void gfc_create_function_decl (gfc_namespace *); +void gfc_create_function_decl (gfc_namespace *, bool); /* Generate the code for a function. */ void gfc_generate_function_code (gfc_namespace *); /* Output a BLOCK DATA program unit. */ @@ -537,7 +537,7 @@ void gfc_process_block_locals (gfc_namespace*); /* Output initialization/clean-up code that was deferred. */ void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *); -/* somewhere! */ +/* In f95-lang.c. */ tree pushdecl (tree); tree pushdecl_top_level (tree); void pushlevel (int); @@ -545,6 +545,8 @@ tree poplevel (int, int, int); tree getdecls (void); tree gfc_truthvalue_conversion (tree); tree gfc_builtin_function (tree); + +/* In trans-types.c. */ struct array_descr_info; bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index de8eb354a8cc..9ce38788dd28 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,10 @@ -2010-07-19 Iain Sandoe +2010-07-26 Tobias Burnus + + PR fortran/40873 + * gfortran.dg/whole_file_22.f90: New test. + * gfortran.dg/whole_file_23.f90: New test. + +2010-07-26 Iain Sandoe Jack Howarth Richard Henderson diff --git a/gcc/testsuite/gfortran.dg/whole_file_22.f90 b/gcc/testsuite/gfortran.dg/whole_file_22.f90 new file mode 100644 index 000000000000..4e229207ccdd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_22.f90 @@ -0,0 +1,38 @@ +! { dg-do link } +! { dg-options "-fwhole-program -O3 -g" } +! +! PR fortran/40873 +! + program prog + call one() + call two() + call test() + end program prog + subroutine one() + call three() + end subroutine one + subroutine two() + call three() + end subroutine two + subroutine three() + end subroutine three + +SUBROUTINE c() + CALL a() +END SUBROUTINE c + +SUBROUTINE a() +END SUBROUTINE a + +MODULE M +CONTAINS + SUBROUTINE b() + CALL c() + END SUBROUTINE +END MODULE + +subroutine test() +USE M +CALL b() +END + diff --git a/gcc/testsuite/gfortran.dg/whole_file_23.f90 b/gcc/testsuite/gfortran.dg/whole_file_23.f90 new file mode 100644 index 000000000000..c8f66e6cd62a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_23.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/40873 +! +! Failed to compile (segfault) with -fwhole-file. +! Cf. PR 40873 comment 24; test case taken from +! PR fortran/31867 comment 6. +! + +pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + lensum = (size (words)-1) * len (sep) + sum (len_trim (words)) +end function + +module util_mod + implicit none + interface + pure integer function lensum (words, sep) + character (len=*), intent(in) :: words(:), sep + end function + end interface + contains + function join (words, sep) result(str) +! trim and concatenate a vector of character variables, +! inserting sep between them + character (len=*), intent(in) :: words(:), sep + character (len=lensum (words, sep)) :: str + integer :: i, nw + nw = size (words) + str = "" + if (nw < 1) then + return + else + str = words(1) + end if + do i=2,nw + str = trim (str) // sep // words(i) + end do + end function join +end module util_mod +! +program xjoin + use util_mod, only: join + implicit none + character (len=5) :: words(2) = (/"two ","three"/) + write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'" +end program xjoin + +! { dg-final { cleanup-modules "util_mod" } }