Hello world,
the attached patch fixes a 7/8/9 regression. The problem was twofold:
If a subroutine was called more than once from a different subroutine,
the call was only checked the first time. Also, a type change in the
backend_decl initiated when there was already a declaration led to an
ICE.
The solution also has two parts: Make sure that a hard error is
delivered in this case, and make sure the check is done every time.
Regression-tested. OK for trunk and other affected branches?
Regards
Thomas
2019-03-22 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/78865
* interface.c (compare_actual_formal): Change errors about
missing or extra to gfc_error_now to make sure they are issued.
Change "spec" to "specifier" in message.
* resolve.c (resolve_global_procedure): Also check for mismatching
interface with global symbols if the namespace has already been
resolved.
2019-03-22 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/78865
* gfortran.dg/altreturn_10.f90: New test.
* gfortran.dg/whole_file_3.f90: Change dg-warning to dg-error.
Index: fortran/interface.c
===================================================================
--- fortran/interface.c (Revision 269825)
+++ fortran/interface.c (Arbeitskopie)
@@ -2969,9 +2969,11 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
if (f->sym == NULL)
{
+ /* These errors have to be issued, otherwise an ICE can occur.
+ See PR 78865. */
if (where)
- gfc_error ("Missing alternate return spec in subroutine call "
- "at %L", where);
+ gfc_error_now ("Missing alternate return specifier in subroutine "
+ "call at %L", where);
return false;
}
@@ -2978,8 +2980,8 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
if (a->expr == NULL)
{
if (where)
- gfc_error ("Unexpected alternate return spec in subroutine "
- "call at %L", where);
+ gfc_error_now ("Unexpected alternate return specifier in "
+ "subroutine call at %L", where);
return false;
}
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c (Revision 269825)
+++ fortran/resolve.c (Arbeitskopie)
@@ -2498,62 +2498,64 @@ resolve_global_procedure (gfc_symbol *sym, locus *
&& gsym->type != GSYM_UNKNOWN
&& !gsym->binding_label
&& gsym->ns
- && gsym->ns->resolved != -1
&& gsym->ns->proc_name
&& not_in_recursive (sym, gsym->ns)
&& not_entry_self_reference (sym, gsym->ns))
{
gfc_symbol *def_sym;
+ def_sym = gsym->ns->proc_name;
- /* Resolve the gsymbol namespace if needed. */
- if (!gsym->ns->resolved)
+ if (gsym->ns->resolved != -1)
{
- gfc_symbol *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;
+ /* Resolve the gsymbol namespace if needed. */
+ if (!gsym->ns->resolved)
+ {
+ gfc_symbol *old_dt_list;
- gfc_resolve (gsym->ns);
+ /* Stash away derived types so that the backend_decls
+ do not get mixed up. */
+ old_dt_list = gfc_derived_types;
+ gfc_derived_types = NULL;
- /* Store the new derived types with the global namespace. */
- if (gfc_derived_types)
- gsym->ns->derived_types = gfc_derived_types;
+ gfc_resolve (gsym->ns);
- /* Restore the derived types of this namespace. */
- gfc_derived_types = old_dt_list;
- }
+ /* Store the new derived types with the global namespace. */
+ if (gfc_derived_types)
+ gsym->ns->derived_types = gfc_derived_types;
- /* Make sure that translation for the gsymbol occurs before
- the procedure currently being resolved. */
- ns = gfc_global_ns_list;
- for (; ns && ns != gsym->ns; ns = ns->sibling)
- {
- if (ns->sibling == gsym->ns)
+ /* Restore the derived types of this namespace. */
+ gfc_derived_types = old_dt_list;
+ }
+
+ /* Make sure that translation for the gsymbol occurs before
+ the procedure currently being resolved. */
+ ns = gfc_global_ns_list;
+ for (; ns && ns != gsym->ns; ns = ns->sibling)
{
- ns->sibling = gsym->ns->sibling;
- gsym->ns->sibling = gfc_global_ns_list;
- gfc_global_ns_list = gsym->ns;
- break;
+ if (ns->sibling == gsym->ns)
+ {
+ ns->sibling = gsym->ns->sibling;
+ gsym->ns->sibling = gfc_global_ns_list;
+ gfc_global_ns_list = gsym->ns;
+ break;
+ }
}
- }
- def_sym = gsym->ns->proc_name;
+ /* This can happen if a binding name has been specified. */
+ if (gsym->binding_label && gsym->sym_name != def_sym->name)
+ gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
- /* This can happen if a binding name has been specified. */
- if (gsym->binding_label && gsym->sym_name != def_sym->name)
- gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym);
-
- if (def_sym->attr.entry_master)
- {
- gfc_entry_list *entry;
- for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
- {
- def_sym = entry->sym;
- break;
- }
+ if (def_sym->attr.entry_master)
+ {
+ gfc_entry_list *entry;
+ for (entry = gsym->ns->entries; entry; entry = entry->next)
+ if (strcmp (entry->sym->name, sym->name) == 0)
+ {
+ def_sym = entry->sym;
+ break;
+ }
+ }
}
if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts))
Index: testsuite/gfortran.dg/whole_file_3.f90
===================================================================
--- testsuite/gfortran.dg/whole_file_3.f90 (Revision 269825)
+++ testsuite/gfortran.dg/whole_file_3.f90 (Arbeitskopie)
@@ -14,8 +14,8 @@
program test
EXTERNAL R
- call PHLOAD (R, 1) ! { dg-warning "Missing alternate return spec" }
- CALL PHLOAD (R, 2) ! { dg-warning "Missing alternate return spec" }
+ call PHLOAD (R, 1) ! { dg-error "Missing alternate return specifier" }
+ CALL PHLOAD (R, 2) ! { dg-error "Missing alternate return specifier" }
CALL PHLOAD (R, *999) ! This one is OK
999 continue
END program test
! { dg-do compile }
! { dg-options -Os }
! PR 78865 - this used to ICE.
program p
call sub (3)
end
subroutine sub (x)
integer :: x, i, n
do i = 1, x
if ( n /= 0 ) stop
call sub2
end do
print *, x, n
end
subroutine sub2
call sub (*99) ! { dg-error "Unexpected alternate return specifier" }
call sub (99.) ! { dg-warning "Type mismatch in argument" }
99 stop
end
