diff options
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 27 |
1 files changed, 18 insertions, 9 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index ba79190..f059c3c 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3445,7 +3445,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) { 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_expr *rvalue) } } - 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_expr *rvalue) 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_expr *rvalue) 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; |