re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators)

2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.h (gfc_expr): Optionally store base-object in compcall value
	and add a new flag to distinguish assign-calls generated.
	(gfc_find_typebound_proc): Add locus argument.
	(gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_extend_expr): Return if failure was by a real error.
	* interface.c (matching_typebound_op): New routine.
	(build_compcall_for_operator): New routine.
	(gfc_extend_expr): Handle type-bound operators, some clean-up and
	return if failure was by a real error or just by not finding an
	appropriate operator definition.
	(gfc_extend_assign): Handle type-bound assignments.
	* module.c (MOD_VERSION): Incremented.
	(mio_intrinsic_op): New routine.
	(mio_full_typebound_tree): New routine to make typebound-procedures IO
	code reusable for type-bound user operators.
	(mio_f2k_derived): IO of type-bound operators.
	* primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and
	pass locus to gfc_find_typebound_proc.
	* resolve.c (resolve_operator): Only output error about no matching
	interface if gfc_extend_expr did not already fail with an error.
	(extract_compcall_passed_object): Use specified base-object if present.
	(update_compcall_arglist): Handle ignore_pass field.
	(resolve_ordinary_assign): Update to handle extended code for
	type-bound assignments, too.
	(resolve_code): Handle EXEC_ASSIGN_CALL statement code.
	(resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc.
	(resolve_typebound_generic), (resolve_typebound_procedure): Ditto.
	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto.
	(ensure_not_abstract_walker), (resolve_fl_derived): Ditto.
	(resolve_typebound_procedures): Remove not-implemented error.
	(resolve_typebound_call): Handle assign-call flag.
	* symbol.c (find_typebound_proc_uop): New argument to pass locus for
	error message about PRIVATE, verify that a found procedure is not marked
	as erraneous.
	(gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg.

2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/impure_assignment_1.f90: Change expected error message.
	* gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented
	error and fix problem with recursive assignment.
	* gfortran.dg/typebound_operator_2.f03: No not-implemented check.
	* gfortran.dg/typebound_operator_3.f03: New test.
	* gfortran.dg/typebound_operator_4.f03: New test.

From-SVN: r151140

1 files changed, 65 insertions, 46 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3bc4c58..e1c931b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3508,8 +3508,14 @@ resolve_operator (gfc_expr *e)
 
 bad_op:
 
-  if (gfc_extend_expr (e) == SUCCESS)
-    return SUCCESS;
+  {
+    bool real_error;
+    if (gfc_extend_expr (e, &real_error) == SUCCESS)
+      return SUCCESS;
+
+    if (real_error)
+      return FAILURE;
+  }
 
   if (dual_locus_error)
     gfc_error (msg, &op1->where, &op2->where);
@@ -4685,10 +4691,15 @@ extract_compcall_passed_object (gfc_expr* e)
 
   gcc_assert (e->expr_type == EXPR_COMPCALL);
 
-  po = gfc_get_expr ();
-  po->expr_type = EXPR_VARIABLE;
-  po->symtree = e->symtree;
-  po->ref = gfc_copy_ref (e->ref);
+  if (e->value.compcall.base_object)
+    po = gfc_copy_expr (e->value.compcall.base_object);
+  else
+    {
+      po = gfc_get_expr ();
+      po->expr_type = EXPR_VARIABLE;
+      po->symtree = e->symtree;
+      po->ref = gfc_copy_ref (e->ref);
+    }
 
   if (gfc_resolve_expr (po) == FAILURE)
     return NULL;
@@ -4721,7 +4732,7 @@ update_compcall_arglist (gfc_expr* e)
       return FAILURE;
     }
 
-  if (tbp->nopass)
+  if (tbp->nopass || e->value.compcall.ignore_pass)
     {
       gfc_free_expr (po);
       return SUCCESS;
@@ -4957,7 +4968,7 @@ resolve_typebound_call (gfc_code* c)
 
   c->ext.actual = newactual;
   c->symtree = target;
-  c->op = EXEC_CALL;
+  c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
 
   gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
   gfc_free_expr (c->expr1);
@@ -4983,6 +4994,9 @@ resolve_compcall (gfc_expr* e)
       return FAILURE;
     }
 
+  /* These must not be assign-calls!  */
+  gcc_assert (!e->value.compcall.assign);
+
   if (check_typebound_baseobject (e) == FAILURE)
     return FAILURE;
 
@@ -6909,24 +6923,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 
   if (gfc_extend_assign (code, ns) == SUCCESS)
     {
-      lhs = code->ext.actual->expr;
-      rhs = code->ext.actual->next->expr;
-      if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
+      gfc_symbol* assign_proc;
+      gfc_expr** rhsptr;
+
+      if (code->op == EXEC_ASSIGN_CALL)
 	{
-	  gfc_error ("Subroutine '%s' called instead of assignment at "
-		     "%L must be PURE", code->symtree->n.sym->name,
-		     &code->loc);
-	  return rval;
+	  lhs = code->ext.actual->expr;
+	  rhsptr = &code->ext.actual->next->expr;
+	  assign_proc = code->symtree->n.sym;
+	}
+      else
+	{
+	  gfc_actual_arglist* args;
+	  gfc_typebound_proc* tbp;
+
+	  gcc_assert (code->op == EXEC_COMPCALL);
+
+	  args = code->expr1->value.compcall.actual;
+	  lhs = args->expr;
+	  rhsptr = &args->next->expr;
+
+	  tbp = code->expr1->value.compcall.tbp;
+	  gcc_assert (!tbp->is_generic);
+	  assign_proc = tbp->u.specific->n.sym;
 	}
 
       /* Make a temporary rhs when there is a default initializer
 	 and rhs is the same symbol as the lhs.  */
-      if (rhs->expr_type == EXPR_VARIABLE
-	    && rhs->symtree->n.sym->ts.type == BT_DERIVED
-	    && has_default_initializer (rhs->symtree->n.sym->ts.u.derived)
-	    && (lhs->symtree->n.sym == rhs->symtree->n.sym))
-        code->ext.actual->next->expr = gfc_get_parentheses (rhs);
+      if ((*rhsptr)->expr_type == EXPR_VARIABLE
+	    && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
+	    && has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
+	    && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
+	*rhsptr = gfc_get_parentheses (*rhsptr);
 
+      resolve_code (code, ns);
       return true;
     }
 
@@ -6935,8 +6965,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 
   if (rhs->is_boz
       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
-                         "a DATA statement and outside INT/REAL/DBLE/CMPLX",
-                         &code->loc) == FAILURE)
+			 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+			 &code->loc) == FAILURE)
     return false;
 
   /* Handle the case of a BOZ literal on the RHS.  */
@@ -6981,7 +7011,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
  	rlen = rhs->value.character.length;
 
       else if (rhs->ts.u.cl != NULL
-	         && rhs->ts.u.cl->length != NULL
+		 && rhs->ts.u.cl->length != NULL
 		 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
 	rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
 
@@ -7115,6 +7145,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	case EXEC_EXIT:
 	case EXEC_CONTINUE:
 	case EXEC_DT_END:
+	case EXEC_ASSIGN_CALL:
 	  break;
 
 	case EXEC_ENTRY:
@@ -8870,8 +8901,8 @@ resolve_tb_generic_targets (gfc_symbol* super_type,
 	/* Look for an inherited specific binding.  */
 	if (super_type)
 	  {
-	    inherited = gfc_find_typebound_proc (super_type, NULL,
-						 target_name, true);
+	    inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
+						 true, NULL);
 
 	    if (inherited)
 	      {
@@ -8952,7 +8983,8 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
   if (super_type)
     {
       gfc_symtree* overridden;
-      overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+      overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
+					    true, NULL);
 
       if (overridden && overridden->n.tb)
 	st->n.tb->overridden = overridden->n.tb;
@@ -9006,7 +9038,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
   super_type = gfc_get_derived_super_type (derived);
   if (super_type && super_type->f2k_derived)
     p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
-						     op, true);
+						     op, true, NULL);
   else
     p->overridden = NULL;
 
@@ -9021,10 +9053,10 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
 
       target_proc = get_checked_tb_operator_target (target, p->where);
       if (!target_proc)
-	return FAILURE;
+	goto error;
 
       if (!gfc_check_operator_interface (target_proc, op, p->where))
-	return FAILURE;
+	goto error;
     }
 
   return SUCCESS;
@@ -9062,7 +9094,7 @@ resolve_typebound_user_op (gfc_symtree* stree)
     {
       gfc_symtree* overridden;
       overridden = gfc_find_typebound_user_op (super_type, NULL,
-					       stree->name, true);
+					       stree->name, true, NULL);
 
       if (overridden && overridden->n.tb)
 	stree->n.tb->overridden = overridden->n.tb;
@@ -9225,7 +9257,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
     {
       gfc_symtree* overridden;
       overridden = gfc_find_typebound_proc (super_type, NULL,
-					    stree->name, true);
+					    stree->name, true, NULL);
 
       if (overridden && overridden->n.tb)
 	stree->n.tb->overridden = overridden->n.tb;
@@ -9265,7 +9297,6 @@ static gfc_try
 resolve_typebound_procedures (gfc_symbol* derived)
 {
   int op;
-  bool found_op;
 
   if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
     return SUCCESS;
@@ -9277,7 +9308,6 @@ resolve_typebound_procedures (gfc_symbol* derived)
     gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
 			  &resolve_typebound_procedure);
 
-  found_op = (derived->f2k_derived->tb_uop_root != NULL);
   if (derived->f2k_derived->tb_uop_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
 			  &resolve_typebound_user_op);
@@ -9288,17 +9318,6 @@ resolve_typebound_procedures (gfc_symbol* derived)
       if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
 					       p) == FAILURE)
 	resolve_bindings_result = FAILURE;
-      if (p)
-	found_op = true;
-    }
-
-  /* FIXME: Remove this (and found_op) once calls are fully implemented.  */
-  if (found_op)
-    {
-      gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's,"
-		 " they are not yet implemented.",
-		 derived->name, &derived->declared_at);
-      resolve_bindings_result = FAILURE;
     }
 
   return resolve_bindings_result;
@@ -9343,7 +9362,7 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
   if (st->n.tb && st->n.tb->deferred)
     {
       gfc_symtree* overriding;
-      overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
+      overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
       gcc_assert (overriding && overriding->n.tb);
       if (overriding->n.tb->deferred)
 	{
@@ -9594,7 +9613,7 @@ resolve_fl_derived (gfc_symbol *sym)
       /* If this type is an extension, see if this component has the same name
 	 as an inherited type-bound procedure.  */
       if (super_type
-	  && gfc_find_typebound_proc (super_type, NULL, c->name, true))
+	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
 	{
 	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
 		     " inherited type-bound procedure",