===================================================================
@@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
{
char err[200];
gfc_symbol *s1,*s2;
- gfc_component *comp;
+ gfc_component *comp1, *comp2;
const char *name;
attr = gfc_expr_attr (rvalue);
@@ -3549,9 +3549,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
}
}
- comp = gfc_get_proc_ptr_comp (lvalue);
- if (comp)
- s1 = comp->ts.interface;
+ comp1 = gfc_get_proc_ptr_comp (lvalue);
+ if (comp1)
+ s1 = comp1->ts.interface;
else
{
s1 = lvalue->symtree->n.sym;
@@ -3559,18 +3559,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
s1 = s1->ts.interface;
}
- comp = gfc_get_proc_ptr_comp (rvalue);
- if (comp)
+ comp2 = gfc_get_proc_ptr_comp (rvalue);
+ if (comp2)
{
if (rvalue->expr_type == EXPR_FUNCTION)
{
- s2 = comp->ts.interface->result;
+ s2 = comp2->ts.interface->result;
name = s2->name;
}
else
{
- s2 = comp->ts.interface;
- name = comp->name;
+ s2 = comp2->ts.interface;
+ name = comp2->name;
}
}
else if (rvalue->expr_type == EXPR_FUNCTION)
@@ -3591,6 +3591,15 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
if (s2 && s2->attr.proc_pointer && s2->ts.interface)
s2 = s2->ts.interface;
+ /* Special check for the case of absent interface on the lvalue.
+ * All other interface checks are done below. */
+ if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function)
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: '%s' is not a subroutine", &rvalue->where, name);
+ return false;
+ }
+
if (s1 == s2 || !s1 || !s2)
return true;