[Bug fortran/64244] [4.8/4.9/5 Regression] ICE at class.c:236 when using non_overridable

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

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=64244

janus at gcc dot gnu.org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|NEW                         |ASSIGNED
           Assignee|unassigned at gcc dot gnu.org      |janus at gcc dot gnu.org

--- Comment #4 from janus at gcc dot gnu.org ---
(In reply to janus from comment #3)
> 'resolve_typebound_generic_call' should probably communicate to its caller
> that the specific procedure it found is not overridable.

It turns out that resolve_typebound_generic_call actually does update this
information in the gfc_expr, but then resolve_typebound_call needs to pass it
outside, before it transforms the whole thing into an EXEC_CALL.

Here is a draft patch which does this (making the ICE disappear):

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c    (Revision 218748)
+++ gcc/fortran/resolve.c    (Arbeitskopie)
@@ -5667,7 +5667,7 @@ success:
 /* Resolve a call to a type-bound subroutine.  */

 static bool
-resolve_typebound_call (gfc_code* c, const char **name)
+resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
@@ -5691,6 +5691,10 @@ static bool
   if (!resolve_typebound_generic_call (c->expr1, name))
     return false;

+  /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
+  if (overridable)
+    *overridable = !c->expr1->value.compcall.tbp->non_overridable;
+
   /* Transform into an ordinary EXEC_CALL for now.  */

   if (!resolve_typebound_static (c->expr1, &target, &newactual))
@@ -5950,7 +5954,7 @@ resolve_typebound_subroutine (gfc_code *code)
       if (c->ts.u.derived == NULL)
     c->ts.u.derived = gfc_find_derived_vtab (declared);

-      if (!resolve_typebound_call (code, &name))
+      if (!resolve_typebound_call (code, &name, NULL))
     return false;

       /* Use the generic name if it is there.  */
@@ -5982,7 +5986,7 @@ resolve_typebound_subroutine (gfc_code *code)
     }

   if (st == NULL)
-    return resolve_typebound_call (code, NULL);
+    return resolve_typebound_call (code, NULL, NULL);

   if (!resolve_ref (code->expr1))
     return false;
@@ -5995,10 +5999,10 @@ resolve_typebound_subroutine (gfc_code *code)
      || (!class_ref && st->n.sym->ts.type != BT_CLASS))
     {
       gfc_free_ref_list (new_ref);
-      return resolve_typebound_call (code, NULL);
+      return resolve_typebound_call (code, NULL, NULL);
     }

-  if (!resolve_typebound_call (code, &name))
+  if (!resolve_typebound_call (code, &name, &overridable))
     {
       gfc_free_ref_list (new_ref);
       return false;