From b82657f4a84dd4abb65bbf4179a109f1d8a36e92 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sun, 5 Oct 2008 08:39:37 +0200 Subject: [PATCH] re PR fortran/37638 (ICE in update_arglist_pass) 2008-10-05 Daniel Kraft PR fortran/37638 * gfortran.h (struct gfc_typebound_proc): New flag `error'. * resolve.c (update_arglist_pass): Added assertion. (update_compcall_arglist): Fail early for erraneous procedures to avoid confusion later. (resolve_typebound_generic_call): Ignore erraneous specific targets and added assertions. (resolve_typebound_procedure): Set new `error' flag. 2008-10-05 Daniel Kraft PR fortran/37638 * gfortran.dg/typebound_call_9.f03: New test. From-SVN: r140880 --- gcc/fortran/ChangeLog | 11 ++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/resolve.c | 13 ++++ gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/typebound_call_9.f03 | 63 +++++++++++++++++++ 5 files changed, 93 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/typebound_call_9.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d462da0f1741..df358b89c3db 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2008-10-05 Daniel Kraft + + PR fortran/37638 + * gfortran.h (struct gfc_typebound_proc): New flag `error'. + * resolve.c (update_arglist_pass): Added assertion. + (update_compcall_arglist): Fail early for erraneous procedures to avoid + confusion later. + (resolve_typebound_generic_call): Ignore erraneous specific targets + and added assertions. + (resolve_typebound_procedure): Set new `error' flag. + 2008-10-04 Paul Thomas PR fortran/37706 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 60d9baccf9b5..55cca7287692 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1037,6 +1037,7 @@ typedef struct gfc_typebound_proc unsigned non_overridable:1; unsigned is_generic:1; unsigned function:1, subroutine:1; + unsigned error:1; /* Ignore it, when an error occurred during resolution. */ } gfc_typebound_proc; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d682e10dd5aa..6976e64e0c85 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4366,6 +4366,8 @@ fixup_charlen (gfc_expr *e) static gfc_actual_arglist* update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos) { + gcc_assert (argpos > 0); + if (argpos == 1) { gfc_actual_arglist* result; @@ -4417,6 +4419,9 @@ update_compcall_arglist (gfc_expr* e) tbp = e->value.compcall.tbp; + if (tbp->error) + return FAILURE; + po = extract_compcall_passed_object (e); if (!po) return FAILURE; @@ -4497,6 +4502,10 @@ resolve_typebound_generic_call (gfc_expr* e) bool matches; gcc_assert (g->specific); + + if (g->specific->error) + continue; + target = g->specific->u.specific->n.sym; /* Get the right arglist by handling PASS/NOPASS. */ @@ -4508,6 +4517,8 @@ resolve_typebound_generic_call (gfc_expr* e) if (!po) return FAILURE; + gcc_assert (g->specific->pass_arg_num > 0); + gcc_assert (!g->specific->error); args = update_arglist_pass (args, po, g->specific->pass_arg_num); } resolve_actual_arglist (args, target->attr.proc, @@ -8448,10 +8459,12 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } + stree->typebound->error = 0; return; error: resolve_bindings_result = FAILURE; + stree->typebound->error = 1; } static gfc_try diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c0b275c11f8b..8ea4bef2bf3a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2008-10-05 Daniel Kraft + + PR fortran/37638 + * gfortran.dg/typebound_call_9.f03: New test. + 2008-10-04 Paul Thomas PR fortran/37706 diff --git a/gcc/testsuite/gfortran.dg/typebound_call_9.f03 b/gcc/testsuite/gfortran.dg/typebound_call_9.f03 new file mode 100644 index 000000000000..f2e128d3cb2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_call_9.f03 @@ -0,0 +1,63 @@ +! { dg-do compile } + +! FIXME: Remove once polymorphic PASS is resolved +! { dg-options "-w" } + +! PR fortran/37638 +! If a PASS(arg) is invalid, a call to this routine later would ICE in +! resolving. Check that this also works for GENERIC, in addition to the +! PR's original test. + +! Contributed by Salvatore Filippone + +module foo_mod + implicit none + + type base_foo_type + integer :: nr,nc + integer, allocatable :: iv1(:), iv2(:) + + contains + + procedure, pass(a) :: makenull ! { dg-error "has no argument 'a'" } + generic :: null2 => makenull + + end type base_foo_type + +contains + + subroutine makenull(m) + implicit none + type(base_foo_type), intent(inout) :: m + + m%nr=0 + m%nc=0 + + end subroutine makenull + + subroutine foo_free(a,info) + implicit none + Type(base_foo_type), intent(inout) :: A + Integer, intent(out) :: info + integer :: iret + info = 0 + + + if (allocated(a%iv1)) then + deallocate(a%iv1,stat=iret) + if (iret /= 0) info = max(info,2) + endif + if (allocated(a%iv2)) then + deallocate(a%iv2,stat=iret) + if (iret /= 0) info = max(info,3) + endif + + call a%makenull() + call a%null2 () ! { dg-error "no matching specific binding" } + + Return + End Subroutine foo_free + +end module foo_mod + +! { dg-final { cleanup-modules "foo_mod" } }