This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR40011 - Problems with -fwhole-file
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org
- Date: Sat, 27 Jun 2009 23:33:22 +0200
- Subject: [Patch, fortran] PR40011 - Problems with -fwhole-file
Dear All,
As promised at the recent #gfortran meeting, I have put some efforts
into the whole file scope business. At the end of play to day, I have
the following on regtesting with -fwhole-file:
# of expected passes 30821
# of unexpected failures 78
# of expected failures 20
# of unsupported tests 42
All are down to genuine errors in interfaces except:
FAIL: gfortran.dg/func_decl_4.f90 -O (test for errors, line 7)
FAIL: gfortran.dg/func_decl_4.f90 -O (test for errors, line 11)
The errors caused by initialising the function result have
disappeared :-( This has to be trivial.
FAIL: gfortran.dg/func_derived_2.f90 -O1 execution test
Fails with -O1 only!
FAIL: gfortran.dg/import.f90 -O3 -fomit-frame-pointer execution test
FAIL: gfortran.dg/import.f90 -O3 -fomit-frame-pointer -funroll-loops
execution test
FAIL: gfortran.dg/import.f90 -O3 -fomit-frame-pointer
-funroll-all-loops -finline-functions execution test
FAIL: gfortran.dg/import.f90 -O3 -g execution test
Fails at -O3
The calls to 'test' and 'bar' are optimized away and all routes lead
to call abort ().
Adding a print statement to both makes this go away.
FAIL: gfortran.dg/intrinsic_std_1.f90 -O scan-tree-dump original "
abort ": dump file does not exist
FAIL: gfortran.dg/intrinsic_std_1.f90 -O scan-tree-dump original "
asinh ": dump file does not exist
FAIL: gfortran.dg/intrinsic_std_1.f90 -O scan-tree-dump original "
acosh ": dump file does not exist
Exists when I compile outside of dejagnu!?
The dump file does exist but there is only a reference to abort - the
asinh and acosh appear to
have been simplified away.
FAIL: gfortran.fortran-torture/execute/function_module_1.f90 execution, -O2
FAIL: gfortran.fortran-torture/execute/function_module_1.f90
execution, -O2 -fomit-frame-pointer -finline-functions
FAIL: gfortran.fortran-torture/execute/function_module_1.f90
execution, -O2 -fomit-frame-pointer -finline-functions -funroll-loops
FAIL: gfortran.fortran-torture/execute/function_module_1.f90
execution, -O2 -fbounds-check
FAIL: gfortran.fortran-torture/execute/function_module_1.f90 execution, -O3 -g
FAIL: gfortran.fortran-torture/execute/function_module_1.f90 execution, -Os
FAIL: gfortran.fortran-torture/execute/function_module_1.f90
execution, -O2 -ftree-vectorize -msse2
fails at -O2 or greater.
Thus, 61 FAILs are due to genuine errors or F77-isms and the rest are
due to ~6-8 problems with the patch.
The most puzzling is the fail at -O1 only - func_decl_4.f90.
function_module_1.f90 and import.f90 look
either like stretching of the limts of -O2 and -O3 or something
missing from the procedure flags.
func_decl_4.f90 and intrinsic_std_1.f90 will have some rather trivial
explanations.
Thus, it's not quite ready for submission but coming very close. Note
that I have to scrutinise the post compilation clean-up with a
fine-tooth comb and to check gfortran with some of the standard
benchmarks,
Cheers
Paul
PS Have made a first stab at adding [lbound, sm, extent] slightly more
than 200 FAILs, which is not too bad.
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c (revision 149003)
+++ gcc/fortran/error.c (working copy)
@@ -32,6 +32,8 @@
static int suppress_errors = 0;
+static int warnings_not_errors = 0;
+
static int terminal_width, buffer_flag, errors, warnings;
static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
@@ -863,6 +865,9 @@
{
va_list argp;
+ if (warnings_not_errors)
+ goto warning;
+
if (suppress_errors)
return;
@@ -878,6 +883,30 @@
if (buffer_flag == 0)
gfc_increment_error_count();
+
+ return;
+
+warning:
+
+ if (inhibit_warnings)
+ return;
+
+ warning_buffer.flag = 1;
+ warning_buffer.index = 0;
+ cur_error_buffer = &warning_buffer;
+
+ va_start (argp, nocmsgid);
+ error_print (_("Warning:"), _(nocmsgid), argp);
+ va_end (argp);
+
+ error_char ('\0');
+
+ if (buffer_flag == 0)
+ {
+ warnings++;
+ if (warnings_are_errors)
+ gfc_increment_error_count();
+ }
}
@@ -955,6 +984,7 @@
gfc_clear_error (void)
{
error_buffer.flag = 0;
+ warnings_not_errors = 0;
}
@@ -1042,3 +1072,12 @@
if (e != NULL)
*e = errors;
}
+
+
+/* Switch errors into warnings. */
+
+void
+gfc_errors_to_warnings (int f)
+{
+ warnings_not_errors = (f == 1) ? 1 : 0;
+}
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c (revision 149003)
+++ gcc/fortran/options.c (working copy)
@@ -371,6 +371,9 @@
gfc_option.warn_tabs = 0;
}
+ if (pedantic && gfc_option.flag_whole_file)
+ gfc_option.flag_whole_file = 2;
+
gfc_cpp_post_options ();
/* FIXME: return gfc_cpp_preprocess_only ();
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 149003)
+++ gcc/fortran/parse.c (working copy)
@@ -3704,6 +3704,8 @@
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
@@ -3753,6 +3755,76 @@
}
+/* Resolve all the program units when whole file scope option
+ is active. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+ gfc_free_dt_list ();
+ gfc_current_ns = gfc_global_ns_list;
+ for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ gfc_resolve (gfc_current_ns);
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ }
+}
+
+
+static void
+clean_up_modules (gfc_gsymbol *gsym)
+{
+ if (gsym == NULL)
+ return;
+
+ clean_up_modules (gsym->left);
+ clean_up_modules (gsym->right);
+
+ if (gsym->type != GSYM_MODULE || !gsym->ns)
+ return;
+
+ gfc_current_ns = gsym->ns;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_done_2 ();
+ gsym->ns = NULL;
+ return;
+}
+
+
+/* Translate all the program units when whole file scope option
+ is active. This could be in a different order to resolution if
+ there are forward references in the file. */
+static void
+translate_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+ int errors;
+
+ gfc_current_ns = gfc_global_ns_list;
+ gfc_get_errors (NULL, &errors);
+
+
+ for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_generate_code (gfc_current_ns);
+ }
+
+ /* Clean up all the namespaces after translation. */
+ gfc_current_ns = gfc_global_ns_list;
+ for (;gfc_current_ns;)
+ {
+ gfc_namespace *ns = gfc_current_ns->sibling;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_done_2 ();
+ gfc_current_ns = ns;
+ }
+
+ clean_up_modules (gfc_gsym_root);
+}
+
+
/* Top level parser. */
gfc_try
@@ -3877,15 +3949,24 @@
gfc_dump_module (s.sym->name, errors_before == errors);
if (errors == 0)
gfc_generate_module_code (gfc_current_ns);
+ pop_state ();
+ if (!gfc_option.flag_whole_file)
+ gfc_done_2 ();
+ else
+ {
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ gfc_current_ns = NULL;
+ }
}
else
{
if (errors == 0)
gfc_generate_code (gfc_current_ns);
+ pop_state ();
+ gfc_done_2 ();
}
- pop_state ();
- gfc_done_2 ();
goto loop;
prog_units:
@@ -3908,35 +3989,23 @@
if (!gfc_option.flag_whole_file)
goto termination;
- /* Do the resolution. */
- gfc_current_ns = gfc_global_ns_list;
- for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_resolve (gfc_current_ns);
- }
+ /* Do the resolution. */
+ resolve_all_program_units (gfc_global_ns_list);
/* Do the parse tree dump. */
- gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+ gfc_current_ns
+ = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
gfc_dump_parse_tree (gfc_current_ns, stdout);
- fputs ("-----------------------------------------\n\n", stdout);
+ fputs ("------------------------------------------\n\n", stdout);
}
- gfc_current_ns = gfc_global_ns_list;
- gfc_get_errors (NULL, &errors);
+ /* Do the resolution. */
+ translate_all_program_units (gfc_global_ns_list);
- /* Do the translation. This could be in a different order to
- resolution if there are forward references in the file. */
- for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_generate_code (gfc_current_ns);
- }
-
termination:
- gfc_free_dt_list ();
gfc_end_source_files ();
return SUCCESS;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 149003)
+++ gcc/fortran/resolve.c (working copy)
@@ -1645,6 +1645,47 @@
The namespace of the gsymbol is resolved and then, once this is
done the interface is checked. */
+
+static bool
+not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+ if (!gsym_ns->proc_name->attr.recursive)
+ return true;
+
+ if (sym->ns == gsym_ns)
+ return false;
+
+ if (sym->ns->parent && sym->ns->parent == gsym_ns)
+ return false;
+
+ return true;
+}
+
+static bool
+not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+ if (gsym_ns->entries)
+ {
+ gfc_entry_list *entry = gsym_ns->entries;
+
+ for (; entry; entry = entry->next)
+ {
+ if (strcmp (sym->name, entry->sym->name) == 0)
+ {
+ if (strcmp (gsym_ns->proc_name->name,
+ sym->ns->proc_name->name) == 0)
+ return false;
+
+ if (sym->ns->parent
+ && strcmp (gsym_ns->proc_name->name,
+ sym->ns->parent->proc_name->name) == 0)
+ return false;
+ }
+ }
+ }
+ return true;
+}
+
static void
resolve_global_procedure (gfc_symbol *sym, locus *where,
gfc_actual_arglist **actual, int sub)
@@ -1661,9 +1702,13 @@
gfc_global_used (gsym, where);
if (gfc_option.flag_whole_file
+ && sym->attr.if_source == IFSRC_UNKNOWN
&& gsym->type != GSYM_UNKNOWN
&& gsym->ns
- && gsym->ns->proc_name)
+ && gsym->ns->resolved != -1
+ && gsym->ns->proc_name
+ && not_in_recursive (sym, gsym->ns)
+ && not_entry_self_reference (sym, gsym->ns))
{
/* Make sure that translation for the gsymbol occurs before
the procedure currently being resolved. */
@@ -1680,9 +1725,41 @@
}
if (!gsym->ns->resolved)
- gfc_resolve (gsym->ns);
+ {
+ gfc_dt_list *old_dt_list;
+ /* Stash away derived types so that the backend_decls do not
+ get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
+
+ gfc_resolve (gsym->ns);
+
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
+
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
+ }
+
+ if (gsym->ns->proc_name->attr.function
+ && gsym->ns->proc_name->as
+ && gsym->ns->proc_name->as->rank
+ && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
+ gfc_error ("The reference to function '%s' at %L either needs an "
+ "explicit INTERFACE or the rank is incorrect", sym->name,
+ where);
+
+ if (gfc_option.flag_whole_file == 1
+ || ((gfc_option.warn_std & GFC_STD_LEGACY)
+ &&
+ !(gfc_option.warn_std & GFC_STD_GNU)))
+ gfc_errors_to_warnings (1);
+
gfc_procedure_use (gsym->ns->proc_name, actual, where);
+
+ gfc_errors_to_warnings (0);
}
if (gsym->type == GSYM_UNKNOWN)
@@ -10941,15 +11018,19 @@
gfc_resolve (gfc_namespace *ns)
{
gfc_namespace *old_ns;
+ code_stack *old_cs_base;
if (ns->resolved)
return;
+ ns->resolved = -1;
old_ns = gfc_current_ns;
+ old_cs_base = cs_base;
resolve_types (ns);
resolve_codes (ns);
gfc_current_ns = old_ns;
+ cs_base = old_cs_base;
ns->resolved = 1;
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 149003)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -568,6 +568,9 @@
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+ if (TREE_STATIC (decl) && DECL_CONTEXT (decl))
+ DECL_UNINLINABLE(DECL_CONTEXT (decl)) = 1;
}
@@ -1301,6 +1304,7 @@
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gfc_option.flag_whole_file
+ && !sym->attr.use_assoc
&& !sym->backend_decl
&& gsym && gsym->ns
&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
@@ -1331,6 +1335,26 @@
return sym->backend_decl;
}
+ /* See if this is a module procedure from the same file. If so,
+ return the backend_decl. */
+ if (sym->module)
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+ if (gfc_option.flag_whole_file
+ && gsym && gsym->ns
+ && gsym->type == GSYM_MODULE)
+ {
+ gfc_symbol *s;
+
+ s = NULL;
+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ {
+ sym->backend_decl = s->backend_decl;
+ return sym->backend_decl;
+ }
+ }
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 149003)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -4278,6 +4278,11 @@
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ if (ts.type == BT_DERIVED)
+ TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr))
+ = TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr));
+
+
gfc_add_modify (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (revision 149003)
+++ gcc/fortran/trans-types.c (working copy)
@@ -1851,7 +1851,8 @@
in 4.4.2 and resolved by gfc_compare_derived_types. */
static int
-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
+ bool from_gsym)
{
gfc_component *to_cm;
gfc_component *from_cm;
@@ -1874,7 +1875,8 @@
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
{
to_cm->backend_decl = from_cm->backend_decl;
- if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)
+ if ((!from_cm->attr.pointer || from_gsym)
+ && from_cm->ts.type == BT_DERIVED)
gfc_get_derived_type (to_cm->ts.derived);
else if (from_cm->ts.type == BT_CHARACTER)
@@ -1911,6 +1913,7 @@
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
gfc_component *c;
gfc_dt_list *dt;
+ gfc_gsymbol *gsym;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
@@ -1942,7 +1945,25 @@
return derived->backend_decl;
}
-
+
+ if (gfc_option.flag_whole_file
+ && derived->attr.use_assoc
+ && derived->module)
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
+ if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+ {
+ gfc_symbol *s;
+ s = NULL;
+ gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ {
+ copy_dt_decls_ifequal (s, derived, true);
+ goto copy_derived_types;
+ }
+ }
+ }
+
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
@@ -2069,9 +2090,11 @@
derived->backend_decl = typenode;
+copy_derived_types:
+
/* Add this backend_decl to all the other, equal derived types. */
for (dt = gfc_derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
+ copy_dt_decls_ifequal (derived, dt->derived, false);
return derived->backend_decl;
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 149003)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1301,6 +1301,8 @@
gfc_charlen *cl_list, *old_cl_list;
+ gfc_dt_list *derived_types;
+
int save_all, seen_save, seen_implicit_none;
/* Normally we don't need to refcount namespaces. However when we read
@@ -2256,6 +2258,7 @@
void gfc_free_error (gfc_error_buf *);
void gfc_get_errors (int *, int *);
+void gfc_errors_to_warnings (int);
/* arith.c */
void gfc_arith_init_1 (void);
Index: gcc/testsuite/gfortran.dg/whole_file_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_10.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_10.f90 (revision 0)
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fifth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+recursive function fac(i) result (res)
+ integer :: i, j, k, res
+ k = 1
+ goto 100
+entry bifac(i,j) result (res)
+ k = j
+100 continue
+ if (i < k) then
+ res = 1
+ else
+ res = i * bifac(i-k,k)
+ end if
+end function
+
+program test
+ external fac
+ external bifac
+ integer :: fac, bifac
+ print *, fac(5)
+ print *, bifac(5,2)
+ print*, fac(6)
+ print *, bifac(6,2)
+ print*, fac(0)
+ print *, bifac(1,2)
+end program test
+
Index: gcc/testsuite/gfortran.dg/whole_file_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_11.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_11.f90 (revision 0)
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+!
+! Tests the fix PR40011 comment 16 in which the derived type lists in
+! different program units were getting mixed up.
+!
+! Contributed by Daniel Franck <dfranke@gcc.gnu.org>
+!
+MODULE module_foo
+ TYPE :: foo_node
+ TYPE(foo_node_private), POINTER :: p
+ END TYPE
+
+ TYPE :: foo_node_private
+ TYPE(foo_node), DIMENSION(-1:1) :: link
+ END TYPE
+
+ TYPE :: foo
+ TYPE(foo_node) :: root
+ END TYPE
+END MODULE
+
+FUNCTION foo_insert()
+ USE module_foo, ONLY: foo, foo_node
+
+ INTEGER :: foo_insert
+ TYPE(foo_node) :: parent, current
+ INTEGER :: cmp
+
+ parent = current
+ current = current%p%link(cmp)
+END FUNCTION
+
+FUNCTION foo_count()
+ USE module_foo, ONLY: foo
+ INTEGER :: foo_count
+END FUNCTION
+! { dg-final { cleanup-modules "module_foo" } }
+
Index: gcc/testsuite/gfortran.dg/whole_file_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_12.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_12.f90 (revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+!
+! Tests the fix PR40011 comment 17 in which the explicit interface was
+! being ignored and the missing argument was not correctly handled, which
+! led to an ICE.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr
+!
+ Implicit None
+ call sub(1,2)
+ call sub(1,2,3)
+
+ contains
+
+ subroutine sub(i,j,k)
+ Implicit None
+ Integer, Intent( In ) :: i
+ Integer, Intent( In ) :: j
+ Integer, Intent( In ), Optional :: k
+ intrinsic present
+ write(*,*)' 3 presence flag ',present(k)
+ write(*,*)' 1st arg ',i
+ write(*,*)' 2nd arg ',j
+ if (present(k)) then
+ write(*,*)' 3rd arg ',k
+ else
+ write(*,*)' 3rd arg is absent'
+ endif
+ return
+ end subroutine
+
+ end
+
Index: gcc/testsuite/gfortran.dg/whole_file_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_7.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_7.f90 (revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fixes for the first two problems in PR40011
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+! This function would not compile because -fwhole-file would
+! try repeatedly to resolve the function because of the self
+! reference.
+RECURSIVE FUNCTION eval_args(q) result (r)
+ INTEGER NNODE
+ PARAMETER (NNODE = 10)
+ TYPE NODE
+ SEQUENCE
+ INTEGER car
+ INTEGER cdr
+ END TYPE NODE
+ TYPE(NODE) heap(NNODE)
+ INTEGER r, q
+ r = eval_args(heap(q)%cdr)
+END FUNCTION eval_args
+
+function test(n)
+ real, dimension(2) :: test
+ integer :: n
+ test = n
+ return
+end function test
+
+program arr ! The error was not picked up causing an ICE
+ real, dimension(2) :: res
+ res = test(2) ! { dg-error "needs an explicit INTERFACE" }
+ print *, res
+end program
Index: gcc/testsuite/gfortran.dg/whole_file_8.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_8.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_8.f90 (revision 0)
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the third problem in PR40011, where false
+! type/rank mismatches were found in the main program calls.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+subroutine test_d(fn, val, res)
+ double precision fn
+ double precision val, res
+
+ print *, fn(val), res
+end subroutine
+
+subroutine test_c(fn, val, res)
+ complex fn
+ complex val, res
+
+ print *, fn(val), res
+end subroutine
+
+program specifics
+
+ intrinsic dcos
+ intrinsic dcosh
+ intrinsic dexp
+
+ intrinsic conjg
+
+ call test_d (dcos, 1d0, dcos(1d0))
+ call test_d (dcosh, 1d0, dcosh(1d0))
+ call test_d (dexp, 1d0, dexp(1d0))
+
+ call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0)))
+
+end program
+
Index: gcc/testsuite/gfortran.dg/whole_file_9.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_9.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_9.f90 (revision 0)
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fourth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+program test
+interface
+ function bad_stuff(n)
+ integer :: bad_stuff (2)
+ integer :: n(2)
+ end function bad_stuff
+ recursive function rec_stuff(n) result (tmp)
+ integer :: n(2), tmp(2)
+ end function rec_stuff
+end interface
+ integer :: res(2)
+ res = bad_stuff((/-19,-30/))
+
+end program test
+
+ recursive function bad_stuff(n)
+ integer :: bad_stuff (2)
+ integer :: n(2), tmp(2), ent = 0, sent = 0
+ save ent, sent
+ ent = -1
+ entry rec_stuff(n) result (tmp)
+ if (ent == -1) then
+ sent = ent
+ ent = 0
+ end if
+ ent = ent + 1
+ tmp = 1
+ if(maxval (n) < 5) then
+ tmp = tmp + rec_stuff (n+1)
+ ent = ent - 1
+ endif
+ if (ent == 1) then
+ if (sent == -1) then
+ bad_stuff = tmp + bad_stuff (1)
+ end if
+ ent = 0
+ sent = 0
+ end if
+ end function bad_stuff