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

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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@140880 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d462da0..df358b8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2008-10-05  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  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/37706

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 60d9bac..55cca72 100644 (file)
--- 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 d682e10..6976e64 100644 (file)
--- 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 c0b275c..8ea4bef 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-10-05  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/37638
+       * gfortran.dg/typebound_call_9.f03: New test.
+
 2008-10-04  Paul Thomas  <pault@gcc.gnu.org>
 
        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 (file)
index 0000000..f2e128d
--- /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 <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" } }