[Patch, Fortran] PR fortran/37638: Possible ICE-on-invalid for typebound calls

[Daniel Kraft <d at domob dot eu>]

Hi,

when an error is detected during resolution of a type-bound procedure 
binding (like PASS(invalid) where invalid is no actual argument name of 
the target procedure) this error is of course reported, but nothing else 
is done at the moment.  This leads to the problem that the procedure is 
possibly left in an "invalid" state and a later call to it ICEd in the 
PR; with GENERIC procedures basically "the same" is is also possible as 
in the PR's test, see the extended test case in the patch.

This patch adds a new flag to the gfc_typebound_proc structure to flag 
erraneous ones during resolution; later on, those are ignored for calls.

If a GENERIC call is encountered that should resolve to an erraneous 
specific binding, a "no matching specific binding" error is output.  On 
the other hand, if such a procedure is called directly, no error message 
is printed as the main error is the one printed for the PROCEDURE 
itself.  (See the test-case for an example on what errors are printed / 
not printed.)  I believe this is the best solution.  What do you think?

Currently regression testing on GNU/Linux-x86-32.  Ok for trunk if no 
regressions?

Yours,
Daniel

--
Done:  Arc-Bar-Cav-Rog-Sam-Val-Wiz
To go: Hea-Kni-Mon-Pri-Ran-Tou

2008-10-04  Daniel Kraft  <d@domob.eu>

	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  Daniel Kraft  <d@domob.eu>

	PR fortran/37638
	* gfortran.dg/typebound_call_9.f03: New test.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 140866)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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;
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 140866)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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
 	  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
 	      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
       goto error;
     }
 
+  stree->typebound->error = 0;
   return;
 
 error:
   resolve_bindings_result = FAILURE;
+  stree->typebound->error = 1;
 }
 
 static gfc_try
Index: gcc/testsuite/gfortran.dg/typebound_call_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_9.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_9.f03	(revision 0)
@@ -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 Fillipone <sfilippone@uniroma2.it>
+
+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" } }