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

1 files changed, 30 insertions, 26 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 16661fd..9a95d34 100644
--- a/gcc/fortran/resolve.c
+++ b/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: