diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 23 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 45 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 6 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_22.f90 | 38 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_23.f90 | 49 |
8 files changed, 161 insertions, 23 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cd8e6e4..7700e0b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-07-26 Tobias Burnus <burnus@net-b.de> + + 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 <rth@redhat.com> PR target/44132 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fb9aadc..dab533d 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 4a3fcd8..5d6ea02 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 003f609..4bd4f3b 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 9872e83..99f0dc0 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 de8eb35..9ce3878 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,4 +1,10 @@ -2010-07-19 Iain Sandoe <iains@gcc.gnu.org> +2010-07-26 Tobias Burnus <burnus@net-b.de> + + PR fortran/40873 + * gfortran.dg/whole_file_22.f90: New test. + * gfortran.dg/whole_file_23.f90: New test. + +2010-07-26 Iain Sandoe <iains@gcc.gnu.org> Jack Howarth <howarth@bromo.med.uc.edu> Richard Henderson <rth@redhat.com> 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 0000000..4e22920 --- /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 0000000..c8f66e6 --- /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" } } |