re PR fortran/42385 ([OOP] poylmorphic operators do not work)

2010-07-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* interface.c (matching_typebound_op): Add argument for the
	return of the generic name for the procedure.
	(build_compcall_for_operator): Add an argument for the generic
	name of an operator procedure and supply it to the expression.
	(gfc_extend_expr, gfc_extend_assign): Use the generic name in
	calls to the above procedures.
	* resolve.c (resolve_typebound_function): Catch procedure
	component calls for CLASS objects, check that the vtable is
	complete and insert the $vptr and procedure components, to make
	the call.
	(resolve_typebound_function): The same.
	* trans-decl.c (gfc_trans_deferred_vars): Do not deallocate
	an allocatable scalar if it is a result.


2010-07-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* gfortran.dg/class_defined_operator_1.f03 : New test.

From-SVN: r162313

1 files changed, 20 insertions, 11 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 587b09c..201961d 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2779,12 +2779,14 @@ gfc_find_sym_in_symtree (gfc_symbol *sym)
 /* See if the arglist to an operator-call contains a derived-type argument
    with a matching type-bound operator.  If so, return the matching specific
    procedure defined as operator-target as well as the base-object to use
-   (which is the found derived-type argument with operator).  */
+   (which is the found derived-type argument with operator).  The generic
+   name, if any, is transmitted to the final expression via 'gname'.  */
 
 static gfc_typebound_proc*
 matching_typebound_op (gfc_expr** tb_base,
 		       gfc_actual_arglist* args,
-		       gfc_intrinsic_op op, const char* uop)
+		       gfc_intrinsic_op op, const char* uop,
+		       const char ** gname)
 {
   gfc_actual_arglist* base;
 
@@ -2850,6 +2852,7 @@ matching_typebound_op (gfc_expr** tb_base,
 		if (matches)
 		  {
 		    *tb_base = base->expr;
+		    *gname = g->specific_st->name;
 		    return g->specific;
 		  }
 	      }
@@ -2868,11 +2871,12 @@ matching_typebound_op (gfc_expr** tb_base,
 
 static void
 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
-			     gfc_expr* base, gfc_typebound_proc* target)
+			     gfc_expr* base, gfc_typebound_proc* target,
+			     const char *gname)
 {
   e->expr_type = EXPR_COMPCALL;
   e->value.compcall.tbp = target;
-  e->value.compcall.name = "operator"; /* Should not matter.  */
+  e->value.compcall.name = gname ? gname : "$op";
   e->value.compcall.actual = actual;
   e->value.compcall.base_object = base;
   e->value.compcall.ignore_pass = 1;
@@ -2898,6 +2902,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   gfc_namespace *ns;
   gfc_user_op *uop;
   gfc_intrinsic_op i;
+  const char *gname;
 
   sym = NULL;
 
@@ -2905,6 +2910,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   actual->expr = e->value.op.op1;
 
   *real_error = false;
+  gname = NULL;
 
   if (e->value.op.op2 != NULL)
     {
@@ -2970,7 +2976,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
       /* See if we find a matching type-bound operator.  */
       if (i == INTRINSIC_USER)
 	tbo = matching_typebound_op (&tb_base, actual,
-				     i, e->value.op.uop->name);
+				     i, e->value.op.uop->name, &gname);
       else
 	switch (i)
 	  {
@@ -2978,10 +2984,10 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   case INTRINSIC_##comp: \
   case INTRINSIC_##comp##_OS: \
     tbo = matching_typebound_op (&tb_base, actual, \
-				 INTRINSIC_##comp, NULL); \
+				 INTRINSIC_##comp, NULL, &gname); \
     if (!tbo) \
       tbo = matching_typebound_op (&tb_base, actual, \
-				   INTRINSIC_##comp##_OS, NULL); \
+				   INTRINSIC_##comp##_OS, NULL, &gname); \
     break;
 	    CHECK_OS_COMPARISON(EQ)
 	    CHECK_OS_COMPARISON(NE)
@@ -2992,7 +2998,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
 #undef CHECK_OS_COMPARISON
 
 	    default:
-	      tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
 	      break;
 	  }
 	      
@@ -3003,7 +3009,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
 	  gfc_try result;
 
 	  gcc_assert (tb_base);
-	  build_compcall_for_operator (e, actual, tb_base, tbo);
+	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
 
 	  result = gfc_resolve_expr (e);
 	  if (result == FAILURE)
@@ -3050,6 +3056,9 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   gfc_actual_arglist *actual;
   gfc_expr *lhs, *rhs;
   gfc_symbol *sym;
+  const char *gname;
+
+  gname = NULL;
 
   lhs = c->expr1;
   rhs = c->expr2;
@@ -3085,7 +3094,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
       /* See if we find a matching type-bound assignment.  */
       tbo = matching_typebound_op (&tb_base, actual,
-				   INTRINSIC_ASSIGN, NULL);
+				   INTRINSIC_ASSIGN, NULL, &gname);
 	      
       /* If there is one, replace the expression with a call to it and
 	 succeed.  */
@@ -3093,7 +3102,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 	{
 	  gcc_assert (tb_base);
 	  c->expr1 = gfc_get_expr ();
-	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
 	  c->expr1->value.compcall.assign = 1;
 	  c->expr2 = NULL;
 	  c->op = EXEC_COMPCALL;