re PR fortran/43291 ([OOP] Type mismatch in argument; passed CLASS(t1) to CLASS(t2))

2010-03-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* resolve.c (resolve_compcall): Add new boolean dummy argument
	'class_members'. Only resolve expression at end if false.
	Remove redundant, static variable 'class_object'.
	(check_class_members): Add extra argument to call of
	resolve_compcall.
	(resolve_typebound_function): Renamed resolve_class_compcall.
	Do all the detection of class references here. Correct calls to
	resolve_compcall for extra argument.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-03-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43291
	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_7.f03: New test.

From-SVN: r157411

gcc/fortran/ChangeLog

+2010-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43291
+	PR fortran/43326
+	* resolve.c (resolve_compcall): Add new boolean dummy argument
+	'class_members'. Only resolve expression at end if false.
+	Remove redundant, static variable 'class_object'.
+	(check_class_members): Add extra argument to call of
+	resolve_compcall.
+	(resolve_typebound_function): Renamed resolve_class_compcall.
+	Do all the detection of class references here. Correct calls to
+	resolve_compcall for extra argument.
+	(resolve_typebound_subroutine): resolve_class_typebound_call
+	renamed. Otherwise same as resolve_typebound_function.
+	(gfc_resolve_expr): Call resolve_typebound_function.
+	(resolve_code): Call resolve_typebound_subroutine.
+
 2010-03-10  Tobias Burnus  <burnus@net-b.de
 
 	PR fortran/43303

gcc/fortran/resolve.c

@@ -5082,7 +5082,7 @@ resolve_typebound_call (gfc_code* c)
    resolving subroutine class methods, since we do not have to add a
    gfc_code each time. */
 static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn)
+resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
@@ -5132,10 +5132,10 @@ resolve_compcall (gfc_expr* e, bool fcn)
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
-  /* Resolution is not necessary if this is a class subroutine; this
-     function only has to identify the specific proc. Resolution of
-     the call will be done next in resolve_typebound_call.  */
-  return fcn ? gfc_resolve_expr (e) : SUCCESS;
+  /* Resolution is not necessary when constructing component calls
+     for class members, since this must only be done for the
+     declared type, which is done afterwards.  */
+  return !class_members ? gfc_resolve_expr (e) : SUCCESS;
 }
 
 
@@ -5147,7 +5147,6 @@ static gfc_expr *list_e;
 static void check_class_members (gfc_symbol *);
 static gfc_try class_try;
 static bool fcn_flag;
-static gfc_symbol *class_object;
 
 
 static void
@@ -5202,7 +5201,7 @@ check_class_members (gfc_symbol *derived)
 
   /* Do the renaming, PASSing, generic => specific and other
      good things for each class member.  */
-  class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+  class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
 				? class_try : FAILURE;
 
   /* Now transfer the found symbol to the esym list.  */
@@ -5337,9 +5336,13 @@ resolve_arg_exprs (gfc_actual_arglist *arg)
 }
 
 
-/* Resolve a CLASS typebound function, or 'method'.  */
+/* Resolve a typebound function, or 'method'.  First separate all
+   the non-CLASS references by calling resolve_compcall directly.
+   Then treat the CLASS references by resolving for each of the class
+   members in turn.  */
+
 static gfc_try
-resolve_class_compcall (gfc_expr* e)
+resolve_typebound_function (gfc_expr* e)
 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;
@@ -5347,16 +5350,18 @@ resolve_class_compcall (gfc_expr* e)
   gfc_symtree *st;
 
   st = e->symtree;
-  class_object = st->n.sym;
+  if (st == NULL)
+    return resolve_compcall (e, true, false);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
   /* Weed out cases of the ultimate component being a derived type.  */
-  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
-      return resolve_compcall (e, true);
+      return resolve_compcall (e, true, false);
     }
 
   /* Resolve the argument expressions,  */
@@ -5371,7 +5376,7 @@ resolve_class_compcall (gfc_expr* e)
   list_e = gfc_copy_expr (e);
   check_class_members (derived);
 
-  class_try = (resolve_compcall (e, true) == SUCCESS)
+  class_try = (resolve_compcall (e, true, false) == SUCCESS)
 		 ? class_try : FAILURE;
 
   /* Transfer the class list to the original expression.  Note that
@@ -5392,9 +5397,13 @@ resolve_class_compcall (gfc_expr* e)
   return class_try;
 }
 
-/* Resolve a CLASS typebound subroutine, or 'method'.  */
+/* Resolve a typebound subroutine, or 'method'.  First separate all
+   the non-CLASS references by calling resolve_typebound_call directly.
+   Then treat the CLASS references by resolving for each of the class
+   members in turn.  */
+
 static gfc_try
-resolve_class_typebound_call (gfc_code *code)
+resolve_typebound_subroutine (gfc_code *code)
 {
   gfc_symbol *derived, *declared;
   gfc_ref *new_ref;
@@ -5402,13 +5411,15 @@ resolve_class_typebound_call (gfc_code *code)
   gfc_symtree *st;
 
   st = code->expr1->symtree;
-  class_object = st->n.sym;
+  if (st == NULL)
+    return resolve_typebound_call (code);
 
   /* Get the CLASS declared type.  */
   declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
   /* Weed out cases of the ultimate component being a derived type.  */
-  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+  if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+	|| (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
       return resolve_typebound_call (code);
@@ -5584,10 +5595,7 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
-      if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
-	t = resolve_class_compcall (e);
-      else
-	t = resolve_compcall (e, true);
+      t = resolve_typebound_function (e);
       break;
 
     case EXPR_SUBSTRING:
@@ -8150,11 +8158,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 
 	case EXEC_COMPCALL:
 	compcall:
-	  if (code->expr1->symtree
-		&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
-	    resolve_class_typebound_call (code);
-	  else
-	    resolve_typebound_call (code);
+	  resolve_typebound_subroutine (code);
 	  break;
 
 	case EXEC_CALL_PPC:

gcc/testsuite/ChangeLog

+2010-03-12  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/43291
+	PR fortran/43326
+	* gfortran.dg/dynamic_dispatch_7.f03: New test.
+
 2010-03-12  Kai Tietz  <kai.tietz@onevision.com>
 
 	* gfortran.dg/default_format_denormal_1.f90: Don't assume

gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03

+! { dg-do run }
+! Test the fix for PR43291, which was a regression that caused
+! incorrect type mismatch errors at line 46. In the course of
+! fixing the PR, it was noted that the dynamic dispatch of the
+! final typebound call was not occurring - hence the dg-do run.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+!
+module m1
+  type  :: t1
+  contains 
+    procedure :: sizeof
+  end type
+contains
+  integer function sizeof(a)
+    class(t1) :: a
+    sizeof = 1
+  end function sizeof
+end module
+
+
+module m2
+  use m1
+  type, extends(t1) :: t2    
+  contains
+    procedure :: sizeof => sizeof2
+  end type
+contains
+  integer function sizeof2(a)
+    class(t2) :: a
+    sizeof2 = 2
+  end function
+end module
+
+
+module m3
+  use m2
+  type :: t3
+    class(t1), pointer  :: a 
+  contains
+    procedure :: sizeof => sizeof3
+  end type
+contains 
+  integer function sizeof3(a)
+    class(t3) :: a
+    sizeof3 = a%a%sizeof()
+  end function 
+end module
+
+  use m1
+  use m2
+  use m3
+  type(t1), target :: x
+  type(t2), target :: y
+  type(t3) :: z
+  z%a => x
+  if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
+  z%a => y
+  if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
+
+end
+
+! { dg-final { cleanup-modules "m1 m2 m3" } }
+