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.
