Re: [Patch, Fortran, OOP] PR 49638: [OOP] length parameter is ignored when overriding type bound character functions with constant length.

[Janus Weil <janus at gcc dot gnu dot org>]

2011/8/6 Thomas Koenig <tkoenig@netcologne.de>:
> Am 06.08.2011 23:10, schrieb Janus Weil:
>>
>> I'm know that this does not exactly fit in any of your categories.
>> However, I still think that throwing an error for every case where we
>> can not prove that the expressions are equal is a good approximation
>> for the purpose, and everything beyond that is mostly academic.
>
> And this is where I disagree, I think we should not raise an error
> if we cannot prove that what the user did was wrong. ?This would
> be a rejects-valid bug.


Well, ok. After this amount of discussion, how about we start with the
easy things: Here is a preparational patch (basically a subset of the
previous one), which does not do any real changes yet, only some
preparation and cleanup:
* It moves check_typebound_override to interface.c and prefixes it
with gfc_ (I don't like moving and modifying it at the same time).
* It add the commutativity of multiplication in gfc_dep_compare_expr.
* It does some minor cleanup in dependency.c (making two routines
static and removing an unused argument).

Ok for trunk?

Cheers,
Janus


2011-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/49638
	* dependency.h (gfc_is_same_range,gfc_are_identical_variables): Remove
	two prototypes.
	* dependency.c (gfc_are_identical_variables): Made static and renamed.
	(gfc_dep_compare_expr): Renamed 'gfc_are_identical_variables', handle
	commutativity of multiplication.
	(gfc_is_same_range): Made static and renamed, removed argument 'def'.
	(check_section_vs_section): Renamed 'gfc_is_same_range'.
	* gfortran.h (gfc_check_typebound_override): New prototype.
	* interface.c (gfc_check_typebound_override): Moved here from ...
	* resolv.c (check_typebound_override): ... here (and renamed).
	(resolve_typebound_procedure): Renamed 'check_typebound_override'.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 177528)
+++ gcc/fortran/interface.c	(working copy)
@@ -3466,3 +3466,197 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
       free (p);
     }
 }
+
+
+/* Check that it is ok for the typebound procedure proc to override the
+   procedure old.  */
+
+gfc_try
+gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+{
+  locus where;
+  const gfc_symbol* proc_target;
+  const gfc_symbol* old_target;
+  unsigned proc_pass_arg, old_pass_arg, argpos;
+  gfc_formal_arglist* proc_formal;
+  gfc_formal_arglist* old_formal;
+
+  /* This procedure should only be called for non-GENERIC proc.  */
+  gcc_assert (!proc->n.tb->is_generic);
+
+  /* If the overwritten procedure is GENERIC, this is an error.  */
+  if (old->n.tb->is_generic)
+    {
+      gfc_error ("Can't overwrite GENERIC '%s' at %L",
+		 old->name, &proc->n.tb->where);
+      return FAILURE;
+    }
+
+  where = proc->n.tb->where;
+  proc_target = proc->n.tb->u.specific->n.sym;
+  old_target = old->n.tb->u.specific->n.sym;
+
+  /* Check that overridden binding is not NON_OVERRIDABLE.  */
+  if (old->n.tb->non_overridable)
+    {
+      gfc_error ("'%s' at %L overrides a procedure binding declared"
+		 " NON_OVERRIDABLE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
+  if (!old->n.tb->deferred && proc->n.tb->deferred)
+    {
+      gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
+		 " non-DEFERRED binding", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is PURE, the overriding must be, too.  */
+  if (old_target->attr.pure && !proc_target->attr.pure)
+    {
+      gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+		 proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
+     is not, the overriding must not be either.  */
+  if (old_target->attr.elemental && !proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+		 " ELEMENTAL", proc->name, &where);
+      return FAILURE;
+    }
+  if (!old_target->attr.elemental && proc_target->attr.elemental)
+    {
+      gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+		 " be ELEMENTAL, either", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is a SUBROUTINE, the overriding must also be a
+     SUBROUTINE.  */
+  if (old_target->attr.subroutine && !proc_target->attr.subroutine)
+    {
+      gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+		 " SUBROUTINE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is a FUNCTION, the overriding must also be a
+     FUNCTION and have the same characteristics.  */
+  if (old_target->attr.function)
+    {
+      if (!proc_target->attr.function)
+	{
+	  gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+		     " FUNCTION", proc->name, &where);
+	  return FAILURE;
+	}
+
+      /* FIXME:  Do more comprehensive checking (including, for instance, the
+	 rank and array-shape).  */
+      gcc_assert (proc_target->result && old_target->result);
+      if (!gfc_compare_types (&proc_target->result->ts,
+			      &old_target->result->ts))
+	{
+	  gfc_error ("'%s' at %L and the overridden FUNCTION should have"
+		     " matching result types", proc->name, &where);
+	  return FAILURE;
+	}
+    }
+
+  /* If the overridden binding is PUBLIC, the overriding one must not be
+     PRIVATE.  */
+  if (old->n.tb->access == ACCESS_PUBLIC
+      && proc->n.tb->access == ACCESS_PRIVATE)
+    {
+      gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+		 " PRIVATE", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* Compare the formal argument lists of both procedures.  This is also abused
+     to find the position of the passed-object dummy arguments of both
+     bindings as at least the overridden one might not yet be resolved and we
+     need those positions in the check below.  */
+  proc_pass_arg = old_pass_arg = 0;
+  if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
+    proc_pass_arg = 1;
+  if (!old->n.tb->nopass && !old->n.tb->pass_arg)
+    old_pass_arg = 1;
+  argpos = 1;
+  for (proc_formal = proc_target->formal, old_formal = old_target->formal;
+       proc_formal && old_formal;
+       proc_formal = proc_formal->next, old_formal = old_formal->next)
+    {
+      if (proc->n.tb->pass_arg
+	  && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
+	proc_pass_arg = argpos;
+      if (old->n.tb->pass_arg
+	  && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
+	old_pass_arg = argpos;
+
+      /* Check that the names correspond.  */
+      if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+	{
+	  gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+		     " to match the corresponding argument of the overridden"
+		     " procedure", proc_formal->sym->name, proc->name, &where,
+		     old_formal->sym->name);
+	  return FAILURE;
+	}
+
+      /* Check that the types correspond if neither is the passed-object
+	 argument.  */
+      /* FIXME:  Do more comprehensive testing here.  */
+      if (proc_pass_arg != argpos && old_pass_arg != argpos
+	  && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+	{
+	  gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
+		     "in respect to the overridden procedure",
+		     proc_formal->sym->name, proc->name, &where);
+	  return FAILURE;
+	}
+
+      ++argpos;
+    }
+  if (proc_formal || old_formal)
+    {
+      gfc_error ("'%s' at %L must have the same number of formal arguments as"
+		 " the overridden procedure", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is NOPASS, the overriding one must also be
+     NOPASS.  */
+  if (old->n.tb->nopass && !proc->n.tb->nopass)
+    {
+      gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+		 " NOPASS", proc->name, &where);
+      return FAILURE;
+    }
+
+  /* If the overridden binding is PASS(x), the overriding one must also be
+     PASS and the passed-object dummy arguments must correspond.  */
+  if (!old->n.tb->nopass)
+    {
+      if (proc->n.tb->nopass)
+	{
+	  gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+		     " PASS", proc->name, &where);
+	  return FAILURE;
+	}
+
+      if (proc_pass_arg != old_pass_arg)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+		     " the same position as the passed-object dummy argument of"
+		     " the overridden procedure", proc->name, &where);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 177528)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2840,6 +2840,7 @@ bool gfc_arglist_matches_symbol (gfc_actual_arglis
 bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
 int gfc_has_vector_subscript (gfc_expr*);
 gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
+gfc_try gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 177528)
+++ gcc/fortran/resolve.c	(working copy)
@@ -10672,200 +10672,6 @@ error:
 }
 
 
-/* Check that it is ok for the typebound procedure proc to override the
-   procedure old.  */
-
-static gfc_try
-check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
-{
-  locus where;
-  const gfc_symbol* proc_target;
-  const gfc_symbol* old_target;
-  unsigned proc_pass_arg, old_pass_arg, argpos;
-  gfc_formal_arglist* proc_formal;
-  gfc_formal_arglist* old_formal;
-
-  /* This procedure should only be called for non-GENERIC proc.  */
-  gcc_assert (!proc->n.tb->is_generic);
-
-  /* If the overwritten procedure is GENERIC, this is an error.  */
-  if (old->n.tb->is_generic)
-    {
-      gfc_error ("Can't overwrite GENERIC '%s' at %L",
-		 old->name, &proc->n.tb->where);
-      return FAILURE;
-    }
-
-  where = proc->n.tb->where;
-  proc_target = proc->n.tb->u.specific->n.sym;
-  old_target = old->n.tb->u.specific->n.sym;
-
-  /* Check that overridden binding is not NON_OVERRIDABLE.  */
-  if (old->n.tb->non_overridable)
-    {
-      gfc_error ("'%s' at %L overrides a procedure binding declared"
-		 " NON_OVERRIDABLE", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* It's an error to override a non-DEFERRED procedure with a DEFERRED one.  */
-  if (!old->n.tb->deferred && proc->n.tb->deferred)
-    {
-      gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
-		 " non-DEFERRED binding", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is PURE, the overriding must be, too.  */
-  if (old_target->attr.pure && !proc_target->attr.pure)
-    {
-      gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
-		 proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is ELEMENTAL, the overriding must be, too.  If it
-     is not, the overriding must not be either.  */
-  if (old_target->attr.elemental && !proc_target->attr.elemental)
-    {
-      gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
-		 " ELEMENTAL", proc->name, &where);
-      return FAILURE;
-    }
-  if (!old_target->attr.elemental && proc_target->attr.elemental)
-    {
-      gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
-		 " be ELEMENTAL, either", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is a SUBROUTINE, the overriding must also be a
-     SUBROUTINE.  */
-  if (old_target->attr.subroutine && !proc_target->attr.subroutine)
-    {
-      gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
-		 " SUBROUTINE", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is a FUNCTION, the overriding must also be a
-     FUNCTION and have the same characteristics.  */
-  if (old_target->attr.function)
-    {
-      if (!proc_target->attr.function)
-	{
-	  gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
-		     " FUNCTION", proc->name, &where);
-	  return FAILURE;
-	}
-
-      /* FIXME:  Do more comprehensive checking (including, for instance, the
-	 rank and array-shape).  */
-      gcc_assert (proc_target->result && old_target->result);
-      if (!gfc_compare_types (&proc_target->result->ts,
-			      &old_target->result->ts))
-	{
-	  gfc_error ("'%s' at %L and the overridden FUNCTION should have"
-		     " matching result types", proc->name, &where);
-	  return FAILURE;
-	}
-    }
-
-  /* If the overridden binding is PUBLIC, the overriding one must not be
-     PRIVATE.  */
-  if (old->n.tb->access == ACCESS_PUBLIC
-      && proc->n.tb->access == ACCESS_PRIVATE)
-    {
-      gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
-		 " PRIVATE", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* Compare the formal argument lists of both procedures.  This is also abused
-     to find the position of the passed-object dummy arguments of both
-     bindings as at least the overridden one might not yet be resolved and we
-     need those positions in the check below.  */
-  proc_pass_arg = old_pass_arg = 0;
-  if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
-    proc_pass_arg = 1;
-  if (!old->n.tb->nopass && !old->n.tb->pass_arg)
-    old_pass_arg = 1;
-  argpos = 1;
-  for (proc_formal = proc_target->formal, old_formal = old_target->formal;
-       proc_formal && old_formal;
-       proc_formal = proc_formal->next, old_formal = old_formal->next)
-    {
-      if (proc->n.tb->pass_arg
-	  && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
-	proc_pass_arg = argpos;
-      if (old->n.tb->pass_arg
-	  && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
-	old_pass_arg = argpos;
-
-      /* Check that the names correspond.  */
-      if (strcmp (proc_formal->sym->name, old_formal->sym->name))
-	{
-	  gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
-		     " to match the corresponding argument of the overridden"
-		     " procedure", proc_formal->sym->name, proc->name, &where,
-		     old_formal->sym->name);
-	  return FAILURE;
-	}
-
-      /* Check that the types correspond if neither is the passed-object
-	 argument.  */
-      /* FIXME:  Do more comprehensive testing here.  */
-      if (proc_pass_arg != argpos && old_pass_arg != argpos
-	  && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
-	{
-	  gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
-		     "in respect to the overridden procedure",
-		     proc_formal->sym->name, proc->name, &where);
-	  return FAILURE;
-	}
-
-      ++argpos;
-    }
-  if (proc_formal || old_formal)
-    {
-      gfc_error ("'%s' at %L must have the same number of formal arguments as"
-		 " the overridden procedure", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is NOPASS, the overriding one must also be
-     NOPASS.  */
-  if (old->n.tb->nopass && !proc->n.tb->nopass)
-    {
-      gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
-		 " NOPASS", proc->name, &where);
-      return FAILURE;
-    }
-
-  /* If the overridden binding is PASS(x), the overriding one must also be
-     PASS and the passed-object dummy arguments must correspond.  */
-  if (!old->n.tb->nopass)
-    {
-      if (proc->n.tb->nopass)
-	{
-	  gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
-		     " PASS", proc->name, &where);
-	  return FAILURE;
-	}
-
-      if (proc_pass_arg != old_pass_arg)
-	{
-	  gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
-		     " the same position as the passed-object dummy argument of"
-		     " the overridden procedure", proc->name, &where);
-	  return FAILURE;
-	}
-    }
-
-  return SUCCESS;
-}
-
-
 /* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
 
 static gfc_try
@@ -11327,11 +11133,14 @@ resolve_typebound_procedure (gfc_symtree* stree)
       overridden = gfc_find_typebound_proc (super_type, NULL,
 					    stree->name, true, NULL);
 
-      if (overridden && overridden->n.tb)
-	stree->n.tb->overridden = overridden->n.tb;
+      if (overridden)
+	{
+	  if (overridden->n.tb)
+	    stree->n.tb->overridden = overridden->n.tb;
 
-      if (overridden && check_typebound_override (stree, overridden) == FAILURE)
-	goto error;
+	  if (gfc_check_typebound_override (stree, overridden) == FAILURE)
+	    goto error;
+	}
     }
 
   /* See if there's a name collision with a component directly in this type.  */
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c	(revision 177528)
+++ gcc/fortran/dependency.c	(working copy)
@@ -118,8 +118,8 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_
 /* Return true for identical variables, checking for references if
    necessary.  Calls identical_array_ref for checking array sections.  */
 
-bool
-gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+static bool
+are_identical_variables (gfc_expr *e1, gfc_expr *e2)
 {
   gfc_ref *r1, *r2;
 
@@ -169,7 +169,7 @@ identical_array_ref (gfc_array_ref *a1, gfc_array_
 	  break;
 
 	default:
-	  gfc_internal_error ("gfc_are_identical_variables: Bad type");
+	  gfc_internal_error ("are_identical_variables: Bad type");
 	}
       r1 = r1->next;
       r2 = r2->next;
@@ -421,7 +421,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
       return 1;
 
     case EXPR_VARIABLE:
-      if (gfc_are_identical_variables (e1, e2))
+      if (are_identical_variables (e1, e2))
 	return 0;
       else
 	return -2;
@@ -438,7 +438,12 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
       if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
 	  && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
 	return 0;
-      /* TODO Handle commutative binary operators here?  */
+      else if (e1->value.op.op == INTRINSIC_TIMES
+	       && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
+	       && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
+	/* Commutativity of multiplication.  */
+	return 0;
+
       return -2;
 
     case EXPR_FUNCTION:
@@ -451,11 +456,11 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 }
 
 
-/* Returns 1 if the two ranges are the same, 0 if they are not, and def
-   if the results are indeterminate.  N is the dimension to compare.  */
+/* Returns 1 if the two ranges are the same and 0 if they are not (or if the
+   results are indeterminate). 'n' is the dimension to compare.  */
 
-int
-gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
+static int
+is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
 {
   gfc_expr *e1;
   gfc_expr *e2;
@@ -472,25 +477,19 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
   if (e1 && !e2)
     {
       i = gfc_expr_is_one (e1, -1);
-      if (i == -1)
-	return def;
-      else if (i == 0)
+      if (i == -1 || i == 0)
 	return 0;
     }
   else if (e2 && !e1)
     {
       i = gfc_expr_is_one (e2, -1);
-      if (i == -1)
-	return def;
-      else if (i == 0)
+      if (i == -1 || i == 0)
 	return 0;
     }
   else if (e1 && e2)
     {
       i = gfc_dep_compare_expr (e1, e2);
-      if (i == -2)
-	return def;
-      else if (i != 0)
+      if (i != 0)
 	return 0;
     }
   /* The strides match.  */
@@ -509,12 +508,10 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 
       /* Check we have values for both.  */
       if (!(e1 && e2))
-	return def;
+	return 0;
 
       i = gfc_dep_compare_expr (e1, e2);
-      if (i == -2)
-	return def;
-      else if (i != 0)
+      if (i != 0)
 	return 0;
     }
 
@@ -532,12 +529,10 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 
       /* Check we have values for both.  */
       if (!(e1 && e2))
-	return def;
+	return 0;
 
       i = gfc_dep_compare_expr (e1, e2);
-      if (i == -2)
-	return def;
-      else if (i != 0)
+      if (i != 0)
 	return 0;
     }
 
@@ -1091,7 +1086,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc
   int start_comparison;
 
   /* If they are the same range, return without more ado.  */
-  if (gfc_is_same_range (l_ar, r_ar, n, 0))
+  if (is_same_range (l_ar, r_ar, n))
     return GFC_DEP_EQUAL;
 
   l_start = l_ar->start[n];
Index: gcc/fortran/dependency.h
===================================================================
--- gcc/fortran/dependency.h	(revision 177528)
+++ gcc/fortran/dependency.h	(working copy)
@@ -37,11 +37,8 @@ gfc_expr *gfc_get_noncopying_intrinsic_argument (g
 int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
 				 gfc_actual_arglist *, gfc_dep_check);
 int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
-int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
+/*int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, bool);*/
 int gfc_expr_is_one (gfc_expr *, int);
 
 int gfc_dep_resolver(gfc_ref *, gfc_ref *, gfc_reverse *);
 int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
-
-bool gfc_are_identical_variables (gfc_expr *, gfc_expr *);
-