diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2016-11-08 17:10:56 +0100 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2016-11-08 17:10:56 +0100 |
| commit | eba5aec8e347d75013268de658efa1c7af93123a (patch) | |
| tree | bb815f15e29ab605ae862ca0d66b1ca1dc275e52 /gcc/fortran/expr.c | |
| parent | c22d8787165e1d8f835bfc3a5e5802c286ace31a (diff) | |
| download | gcc-eba5aec8e347d75013268de658efa1c7af93123a.zip gcc-eba5aec8e347d75013268de658efa1c7af93123a.tar.gz gcc-eba5aec8e347d75013268de658efa1c7af93123a.tar.bz2 | |
re PR fortran/77596 ([F03] procedure pointer component with implicit interface can point to a function)
2016-11-08 Janus Weil <janus@gcc.gnu.org>
PR fortran/77596
* expr.c (gfc_check_pointer_assign): Add special check for procedure-
pointer component with absent interface.
2016-11-08 Janus Weil <janus@gcc.gnu.org>
PR fortran/77596
* gfortran.dg/proc_ptr_comp_46.f90: New test.
From-SVN: r241972
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; |