PR fortran/40011
* error.c : Add static flag 'warnings_not_errors'.
(gfc_error): If 'warnings_not_errors' is set, branch to code
from gfc_warning.
(gfc_clear_error): Reset 'warnings_not_errors'.
(gfc_errors_to_warnings): New function.
* options.c (gfc_post_options): If pedantic and flag_whole_file
change the latter to a value of 2.
* parse.c (parse_module): Add module namespace to gsymbol.
(resolve_all_program_units): New function.
(clean_up_modules): New function.
(translate_all_program_units): New function.
(gfc_parse_file): If whole_file, do not clean up module right
away and add derived types to namespace derived types. In
addition, call the three new functions above.
* resolve.c (not_in_recursive): New function.
(not_entry_self_reference): New function.
(resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN,
procedure must not be in the course of being resolved and
must return false for the two new functions. Pack away the
current derived type list before calling gfc_resolve for the
gsymbol namespace. It is unconditionally an error if the ranks
of the reference and ther procedure do not match. Convert
errors to warnings during call to gfc_procedure_use if not
pedantic or legacy.
(gfc_resolve): Set namespace resolved flag to -1 during
resolution and store current cs_base.
* trans-decl.c (gfc_get_symbol_decl): If whole_file compilation
substitute a use associated variable, if it is available in a
gsymbolnamespace.
(gfc_get_extern_function_decl): If the procedure is use assoc,
do not attempt to find it in a gsymbol because it could be an
interface. If the symbol exists in a module namespace, return
its backend_decl.
* trans-expr.c (gfc_trans_scalar_assign): If a derived type
assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs.
* trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a
boolean argument. Copy component backend_decls directly if the
components are derived types and from_gsym is true.
(gfc_get_derived_type): If whole_file copy the derived type from
the module if it is use associated, otherwise, if can be found
in another gsymbol namespace, use the existing derived type as
the TYPE_CANONICAL and build normally.
* gfortran.h : Add derived_types and resolved fields to
gfc_namespace. Include prototype for gfc_errors_to_warnings.
2009-08-01 Paul Thomas <pault@gcc.gnu.org>
PR fortran/40011
* gfortran.dg/whole_file_7.f90: New test.
* gfortran.dg/whole_file_8.f90: New test.
* gfortran.dg/whole_file_9.f90: New test.
* gfortran.dg/whole_file_10.f90: New test.
* gfortran.dg/whole_file_11.f90: New test.
* gfortran.dg/whole_file_12.f90: New test.
* gfortran.dg/whole_file_13.f90: New test.
* gfortran.dg/whole_file_14.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150333
138bc75d-0d04-0410-961f-
82ee72b054a4
+2009-08-01 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/40011
+ * error.c : Add static flag 'warnings_not_errors'.
+ (gfc_error): If 'warnings_not_errors' is set, branch to code
+ from gfc_warning.
+ (gfc_clear_error): Reset 'warnings_not_errors'.
+ (gfc_errors_to_warnings): New function.
+ * options.c (gfc_post_options): If pedantic and flag_whole_file
+ change the latter to a value of 2.
+ * parse.c (parse_module): Add module namespace to gsymbol.
+ (resolve_all_program_units): New function.
+ (clean_up_modules): New function.
+ (translate_all_program_units): New function.
+ (gfc_parse_file): If whole_file, do not clean up module right
+ away and add derived types to namespace derived types. In
+ addition, call the three new functions above.
+ * resolve.c (not_in_recursive): New function.
+ (not_entry_self_reference): New function.
+ (resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN,
+ procedure must not be in the course of being resolved and
+ must return false for the two new functions. Pack away the
+ current derived type list before calling gfc_resolve for the
+ gsymbol namespace. It is unconditionally an error if the ranks
+ of the reference and ther procedure do not match. Convert
+ errors to warnings during call to gfc_procedure_use if not
+ pedantic or legacy.
+ (gfc_resolve): Set namespace resolved flag to -1 during
+ resolution and store current cs_base.
+ * trans-decl.c (gfc_get_symbol_decl): If whole_file compilation
+ substitute a use associated variable, if it is available in a
+ gsymbolnamespace.
+ (gfc_get_extern_function_decl): If the procedure is use assoc,
+ do not attempt to find it in a gsymbol because it could be an
+ interface. If the symbol exists in a module namespace, return
+ its backend_decl.
+ * trans-expr.c (gfc_trans_scalar_assign): If a derived type
+ assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs.
+ * trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a
+ boolean argument. Copy component backend_decls directly if the
+ components are derived types and from_gsym is true.
+ (gfc_get_derived_type): If whole_file copy the derived type from
+ the module if it is use associated, otherwise, if can be found
+ in another gsymbol namespace, use the existing derived type as
+ the TYPE_CANONICAL and build normally.
+ * gfortran.h : Add derived_types and resolved fields to
+ gfc_namespace. Include prototype for gfc_errors_to_warnings.
+
2009-07-29 Tobias Burnus <burnus@net-b.de>
PR fortran/40898
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;
{
va_list argp;
+ if (warnings_not_errors)
+ goto warning;
+
if (suppress_errors)
return;
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();
+ }
}
gfc_clear_error (void)
{
error_buffer.flag = 0;
+ warnings_not_errors = 0;
}
if (e != NULL)
*e = errors;
}
+
+
+/* Switch errors into warnings. */
+
+void
+gfc_errors_to_warnings (int f)
+{
+ warnings_not_errors = (f == 1) ? 1 : 0;
+}
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
/* 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;
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);
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 ();
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
}
+/* 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
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:
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. 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);
- }
+ /* Do the translation. */
+ translate_all_program_units (gfc_global_ns_list);
termination:
- gfc_free_dt_list ();
gfc_end_source_files ();
return SUCCESS;
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)
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. */
}
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)
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;
}
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)
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))
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
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
+ /* TODO This is rather obviously the wrong place to do this.
+ However, a number of testcases, such as function_kinds_1
+ and function_types_2 fail without it, by ICEing at
+ fold_const: 2710 (fold_convert_loc). */
+ if (ts.type == BT_DERIVED
+ && gfc_option.flag_whole_file
+ && (TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr))
+ != TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))))
+ {
+ tmp = gfc_evaluate_now (rse->expr, &block);
+ TYPE_MAIN_VARIANT (TREE_TYPE (tmp))
+ = TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr));
+ }
+ else
+ tmp = rse->expr;
+
gfc_add_modify (&block, lse->expr,
- fold_convert (TREE_TYPE (lse->expr), rse->expr));
+ fold_convert (TREE_TYPE (lse->expr), tmp));
}
gfc_add_block_to_block (&block, &lse->post);
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;
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)
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);
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)
/* 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);
derived->backend_decl = typenode;
- /* Add this backend_decl to all the other, equal derived types. */
+copy_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;
}
+2009-08-01 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/40011
+ * gfortran.dg/whole_file_7.f90: New test.
+ * gfortran.dg/whole_file_8.f90: New test.
+ * gfortran.dg/whole_file_9.f90: New test.
+ * gfortran.dg/whole_file_10.f90: New test.
+ * gfortran.dg/whole_file_11.f90: New test.
+ * gfortran.dg/whole_file_12.f90: New test.
+ * gfortran.dg/whole_file_13.f90: New test.
+ * gfortran.dg/whole_file_14.f90: New test.
+
2009-07-31 Jason Merrill <jason@redhat.com>
* g++.dg/cpp0x/initlist22.C: Adjust for new rvalue reference
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
OSDN Git Service
