[Bug fortran/48095] [OOP] Invalid assignment to procedure pointer component not rejected

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

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

janus at gcc dot gnu.org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|UNCONFIRMED                 |ASSIGNED
   Last reconfirmed|                            |2011-09-05
         AssignedTo|unassigned at gcc dot       |janus at gcc dot gnu.org
                   |gnu.org                     |
     Ever Confirmed|0                           |1

--- Comment #7 from janus at gcc dot gnu.org 2011-09-05 12:45:58 UTC ---
(In reply to comment #5)
> Remains to be done: The test case of comment 0. Seemingly, for an
> initialization, the check is not done - while for a normal pointer assignment
> it is (in expr.c's gfc_check_pointer_assign).
> 
> I would assume that one needs a similar check in resolve_structure_cons. There
> are already checks for "pointer initialization" - one probably needs needs to
> add a similar check to the one in gfc_check_pointer_assign.

Right. In principle it would be nice to share the code, e.g. by calling
gfc_check_pointer_assign from resolve_structure_cons. But I'm not sure if there
is an easy way to accomplish this. Otherwise one could just add the check
manually in resolve_structure_cons:


Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c    (revision 178527)
+++ gcc/fortran/resolve.c    (working copy)
@@ -1119,6 +1119,39 @@ resolve_structure_cons (gfc_expr *expr, int init)
              comp->name);
     }

+      if (comp->attr.proc_pointer && comp->ts.interface)
+    {
+      gfc_symbol *s2 = NULL;
+      gfc_component *c2;
+      const char *name;
+      char err[200];
+
+      if (gfc_is_proc_ptr_comp (cons->expr, &c2))
+        {
+          s2 = c2->ts.interface;
+          name = c2->name;
+        }
+      else if (cons->expr->expr_type == EXPR_FUNCTION)
+        {
+          s2 = cons->expr->symtree->n.sym->result;
+          name = cons->expr->symtree->n.sym->result->name;
+        }
+      else if (cons->expr->expr_type != EXPR_NULL)
+        {
+          s2 = cons->expr->symtree->n.sym;
+          name = cons->expr->symtree->n.sym->name;
+        }
+
+      if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1,
+                         err, sizeof(err)))
+        {
+          gfc_error ("In derived type constructor at %L: Interface mismatch"
+             " in procedure pointer component '%s': %s",
+             &cons->expr->where, comp->name, err);
+          return FAILURE;
+        }
+    }
+
       if (!comp->attr.pointer || comp->attr.proc_pointer
       || cons->expr->expr_type == EXPR_NULL)
     continue;



This patch regtests cleanly on x86_64-unknown-linux-gnu.