+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
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
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)
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;
}
/* 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);
&& !(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);
}
&& !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. */
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;
/* 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;
}
/* 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;
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);
/* 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);
if (ns->parent != parent)
continue;
- gfc_create_function_decl (ns);
+ gfc_create_function_decl (ns, false);
}
for (ns = parent->contained; ns; ns = ns->sibling)
/* 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;
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);
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. */
/* 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);
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 *);
-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>
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
