Hi all,
the attached patch fixes an ICE-on-invalid problem with
procedure-pointer components by making sure that we continue resolving
all components of a derived type, even after an error is thrown.
Regtested on x86_64-unknown-linux-gnu. Ok for trunk?
Cheers,
Janus
2015-01-13 Janus Weil <ja...@gcc.gnu.org>
PR fortran/58023
* resolve.c (resolve_fl_derived0): Continue resolving next component
after error.
2015-01-13 Janus Weil <ja...@gcc.gnu.org>
PR fortran/58023
* gfortran.dg/proc_ptr_comp_43.f90: New.
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 219552)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -12389,7 +12389,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_error ("Coarray component %qs at %L must be allocatable with "
"deferred shape", c->name, &c->loc);
- return false;
+ continue;
}
/* F2008, C443. */
@@ -12398,7 +12398,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
"shall not be a coarray", c->name, &c->loc);
- return false;
+ continue;
}
/* F2008, C444. */
@@ -12409,7 +12409,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
gfc_error ("Component %qs at %L with coarray component "
"shall be a nonpointer, nonallocatable scalar",
c->name, &c->loc);
- return false;
+ continue;
}
/* F2008, C448. */
@@ -12417,7 +12417,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
{
gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
"is not an array pointer", c->name, &c->loc);
- return false;
+ continue;
}
if (c->attr.proc_pointer && c->ts.interface)
@@ -12427,7 +12427,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
{
c->tb->error = 1;
- return false;
+ continue;
}
if (ifc->attr.if_source || ifc->attr.intrinsic)
@@ -12471,7 +12471,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
if (cl->length && !cl->resolved
&& !gfc_resolve_expr (cl->length))
- return false;
+ {
+ c->tb->error = 1;
+ continue;
+ }
c->ts.u.cl = cl;
}
}
@@ -12514,7 +12517,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
"at %L has no argument %qs", c->name,
c->tb->pass_arg, &c->loc, c->tb->pass_arg);
c->tb->error = 1;
- return false;
+ continue;
}
}
else
@@ -12528,7 +12531,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
"must have at least one argument",
c->name, &c->loc);
c->tb->error = 1;
- return false;
+ continue;
}
me_arg = c->ts.interface->formal->sym;
}
@@ -12544,7 +12547,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
" the derived type %qs", me_arg->name, c->name,
me_arg->name, &c->loc, sym->name);
c->tb->error = 1;
- return false;
+ continue;
}
/* Check for C453. */
@@ -12554,7 +12557,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
"must be scalar", me_arg->name, c->name, me_arg->name,
&c->loc);
c->tb->error = 1;
- return false;
+ continue;
}
if (me_arg->attr.pointer)
@@ -12563,7 +12566,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
"may not have the POINTER attribute", me_arg->name,
c->name, me_arg->name, &c->loc);
c->tb->error = 1;
- return false;
+ continue;
}
if (me_arg->attr.allocatable)
@@ -12572,12 +12575,15 @@ resolve_fl_derived0 (gfc_symbol *sym)
"may not be ALLOCATABLE", me_arg->name, c->name,
me_arg->name, &c->loc);
c->tb->error = 1;
- return false;
+ continue;
}
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
- gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
- " at %L", c->name, &c->loc);
+ {
+ gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
+ " at %L", c->name, &c->loc);
+ continue;
+ }
}
! { dg-do compile }
!
! PR 58023: [F03] ICE on invalid with bad PPC declaration
!
! Contributed by Andrew Benson <abenso...@gmail.com>
module m
implicit none
abstract interface
double precision function mr()
end function mr
end interface
type :: sfd
procedure(mr), pointer :: mr1 ! { dg-error "must have at least one argument" }
procedure(mr), pointer :: mr2 ! { dg-error "must have at least one argument" }
end type sfd
contains
subroutine go()
implicit none
type(sfd):: d
write (0,*) d%mr2()
return
end subroutine go
end module m
! { dg-final { cleanup-modules "m" } }
