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: gcc-patches <gcc-patches at gcc dot gnu dot org>, fortran at gcc dot gnu dot org
- Date: Fri, 24 Jul 2009 00:05:16 +0200
- Subject: [Patch, fortran] PR40011 - Problems with -fwhole-file
This patch bootstraps and regtests without -fwhole-file. When
regtested with -fwhole-file it fails on legacy features or wrong code
in the tests. I will eliminate the latter as the next step. I have
yet to go through it with a fine toothed comb to be sure that clean up
is OK nor have I prepared the ChangeLogs.
The following fails at any level of optimization with or without
-fwhole-file but is OK in 4.4.1. I cannot tell yet if I have done
something wrong or if the fault is downstream from the fortran
front-end (ie. I have not yet reverted the patch to check). Nor have
I checked if it is expected to pass according to the standard:
! { dg-do run }
! { dg-options "-fwhole-file -O3" }
! Check that the derived types are correctly substituted when
! using whole file compilation.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr
!
module global
type :: mytype
type(mytype),pointer :: this
end type mytype
type(mytype),target :: base
end module global
program test_equi
use global
call check()
if (.not.associated(base%this%this,base)) call abort
if (.not.associated(base%this%this)) call abort
if (.not.associated(base%this)) call abort
contains
subroutine check()
type(mytype),target :: j
base%this => j !have the variables point
j%this => base !to one another
end subroutine check !take j out of scope
end program test_equi
! { dg-final { cleanup-modules "global" } }
With earlier versions of gcc, the conditions are optimized away
completely but now there is a strange remnant that fails.
Enjoy!
Paul
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c (revision 149950)
+++ 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 149950)
+++ 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 149950)
+++ gcc/fortran/parse.c (working copy)
@@ -3760,6 +3760,8 @@
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
@@ -3809,6 +3811,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);
+ gfc_current_ns->translated = 1;
+ }
+
+ /* 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
@@ -3933,15 +4005,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:
@@ -3964,35 +4045,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 translation. */
+ 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 149950)
+++ gcc/fortran/resolve.c (working copy)
@@ -1652,6 +1652,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)
@@ -1668,9 +1709,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. */
@@ -1687,9 +1732,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)
@@ -10981,15 +11058,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 149952)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -578,6 +578,10 @@
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+ /* Code with static variables must not be inlined. */
+ if (TREE_STATIC (decl) && DECL_CONTEXT (decl))
+ DECL_UNINLINABLE(DECL_CONTEXT (decl)) = 1;
}
@@ -1098,6 +1102,32 @@
if (sym->backend_decl)
return sym->backend_decl;
+ /* If use associated and whole file compilation, use the module
+ declaration. This is only needed for intrinsic types because
+ they are substituted for one another during optimization. */
+ if (gfc_option.flag_whole_file
+ && sym->attr.flavor == FL_VARIABLE
+ && sym->ts.type != BT_DERIVED
+ && sym->attr.use_assoc
+ && sym->module)
+ {
+ gfc_gsymbol *gsym;
+
+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);
+ if (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)
+ {
+ if (sym->ts.type == BT_CHARACTER)
+ sym->ts.cl->backend_decl = s->ts.cl->backend_decl;
+ return s->backend_decl;
+ }
+ }
+ }
+
/* Catch function declarations. Only used for actual parameters and
procedure pointers. */
if (sym->attr.flavor == FL_PROCEDURE)
@@ -1341,6 +1371,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))
@@ -1371,6 +1402,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 149950)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -4438,6 +4438,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 149950)
+++ 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)
@@ -1909,8 +1911,12 @@
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
+ tree canonical = NULL_TREE;
+ bool got_canonical = false;
gfc_component *c;
gfc_dt_list *dt;
+ gfc_namespace *ns;
+ gfc_gsymbol *gsym;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
@@ -1942,7 +1948,60 @@
return derived->backend_decl;
}
-
+
+
+ /* If use associated, use the module type for this one. */
+ if (gfc_option.flag_whole_file
+ && derived->backend_decl == NULL
+ && 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;
+ }
+ }
+ }
+
+ /* If a whole file compilation, the derived types from an earlier
+ namespace can be used as the the canonical type. */
+ if (gfc_option.flag_whole_file
+ && derived->backend_decl == NULL
+ && !derived->attr.use_assoc
+ && gfc_global_ns_list)
+ {
+ for (ns = gfc_global_ns_list;
+ ns->translated && !got_canonical;
+ ns = ns->sibling)
+ {
+ dt = ns->derived_types;
+ for (; dt && !canonical; dt = dt->next)
+ {
+ copy_dt_decls_ifequal (dt->derived, derived, true);
+ if (derived->backend_decl)
+ got_canonical = true;
+ }
+ }
+ }
+
+ /* Store up the canonical type to be added to this one. */
+ if (got_canonical)
+ {
+ if (TYPE_CANONICAL (derived->backend_decl))
+ canonical = TYPE_CANONICAL (derived->backend_decl);
+ else
+ canonical = derived->backend_decl;
+
+ derived->backend_decl = NULL_TREE;
+ }
+
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
@@ -2057,6 +2116,7 @@
/* Now we have the final fieldlist. Record it, then lay out the
derived type, including the fields. */
TYPE_FIELDS (typenode) = fieldlist;
+ TYPE_CANONICAL (typenode) = canonical;
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
@@ -2075,9 +2135,10 @@
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 149950)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1326,6 +1326,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
@@ -1347,6 +1349,9 @@
/* Set to 1 if resolved has been called for this namespace. */
int resolved;
+
+ /* Set to 1 if code has been generated for this namespace. */
+ int translated;
}
gfc_namespace;
@@ -2285,6 +2290,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,32 @@
+! { 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,37 @@
+! { 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
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,33 @@
+! { 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_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_13.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_13.f90 (revision 0)
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-options "-fwhole-file -O3" }
+! Check that the TYPE_CANONICAL is being correctly set
+! for the derived types, when whole file compiling.
+! (based on import.f90)
+!
+subroutine test(x)
+ type myType3
+ sequence
+ integer :: i
+ end type myType3
+ type(myType3) :: x
+ if(x%i /= 7) call abort()
+ x%i = 1
+end subroutine test
+
+
+program foo
+ type myType3
+ sequence
+ integer :: i
+ end type myType3
+
+ type(myType3) :: z
+ z%i = 7
+ call test(z)
+ if(z%i /= 1) call abort
+end program foo
Index: gcc/testsuite/gfortran.dg/whole_file_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_14.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_14.f90 (revision 0)
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-options "-fwhole-file -O3" }
+! Check that the derived types are correctly substituted when
+! whole file compiling.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr
+!
+module global
+ type :: mytype
+ type(mytype),pointer :: this
+ end type mytype
+ type(mytype),target :: base
+end module global
+
+program test_equi
+ use global
+ call check()
+ print *, "base%this%this=>base?" , associated(base%this%this,base)
+ print *, "base%this%this=>?" , associated(base%this%this)
+ print *, "base%this=>?" , associated(base%this)
+contains
+ subroutine check()
+ type(mytype),target :: j
+ base%this => j !have the variables point
+ j%this => base !to one another
+ end subroutine check !take j out of scope
+end program test_equi
+! { dg-final { cleanup-modules "global" } }
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,36 @@
+! { 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