[Bug fortran/49638] [OOP] length parameter is ignored when overriding type bound character functions with constant length.

["janus at gcc dot gnu.org" <gcc-bugzilla at gcc dot gnu dot org>]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=49638

--- Comment #6 from janus at gcc dot gnu.org 2011-08-03 19:41:17 UTC ---
The simple constant-length example in comment #0 can be rejected by extending
the resolve.c part of the patch in comment #3 into:


Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c    (revision 177065)
+++ gcc/fortran/resolve.c    (working copy)
@@ -10760,13 +10760,28 @@ check_typebound_override (gfc_symtree* proc, gfc_s
       /* 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))
+      if (!compare_type_rank (proc_target->result, old_target->result))
     {
       gfc_error ("'%s' at %L and the overridden FUNCTION should have"
-             " matching result types", proc->name, &where);
+             " matching result types and ranks", proc->name, &where);
       return FAILURE;
     }
+    
+      if (proc_target->result->ts.type == BT_CHARACTER
+      && proc_target->result->ts.u.cl && proc_target->result->ts.u.cl->length
+      && proc_target->result->ts.u.cl->length->expr_type == EXPR_CONSTANT
+      && old_target->result->ts.u.cl && old_target->result->ts.u.cl &&
old_target->result->ts.u.cl->length
+      && old_target->result->ts.u.cl->length->expr_type == EXPR_CONSTANT
+      && (mpz_cmp (proc_target->result->ts.u.cl->length->value.integer,
+              old_target->result->ts.u.cl->length->value.integer) != 0))
+    {
+      gfc_error ("Character length mismatch (%ld/%ld) between '%s' at '%L' "
+             "and overridden FUNCTION",
+             mpz_get_si (proc_target->ts.u.cl->length->value.integer),
+             mpz_get_si (old_target->ts.u.cl->length->value.integer),
+             proc->name, &where);
+      return FAILURE;
+    }
     }

   /* If the overridden binding is PUBLIC, the overriding one must not be