diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2009-06-27 00:11:15 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2009-06-27 00:11:15 +0200 |
| commit | fc9c6e5d64f4dbdc1f7a53a4fa14ddc3f124f165 (patch) | |
| tree | a011c58836777edcbf0334f314676e4eccd1a4bf /gcc/fortran/expr.c | |
| parent | 9833720d3bf1e5adf2319bb480b882dad8060182 (diff) | |
| download | gcc-fc9c6e5d64f4dbdc1f7a53a4fa14ddc3f124f165.zip gcc-fc9c6e5d64f4dbdc1f7a53a4fa14ddc3f124f165.tar.gz gcc-fc9c6e5d64f4dbdc1f7a53a4fa14ddc3f124f165.tar.bz2 | |
re PR fortran/39997 (Procedure(), pointer & implicit typing: rejects-valid / accepts-invalid?)
2009-06-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/39997
PR fortran/40541
* decl.c (add_hidden_procptr_result): Copy the typespec to the hidden
result.
* expr.c (gfc_check_pointer_assign): Enable interface check for
procedure pointer assignments where the rhs is a function returning a
procedure pointer.
* resolve.c (resolve_symbol): If an external procedure with unspecified
return type can not be implicitly typed, it must be a subroutine.
2009-06-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/39997
PR fortran/40541
* gfortran.dg/proc_ptr_15.f90: Fixed and extended.
* gfortran.dg/proc_ptr_common_1.f90: Fixed invalid test case.
* gfortran.dg/proc_ptr_result_1.f90: Ditto.
* gfortran.dg/proc_ptr_result_5.f90: New.
From-SVN: r148996
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 12 |
1 files changed, 8 insertions, 4 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d2f73d6..2049fa4 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3189,10 +3189,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* TODO: Enable interface check for PPCs. */ if (is_proc_ptr_comp (rvalue, NULL)) return SUCCESS; - if (rvalue->expr_type == EXPR_VARIABLE - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym, 0, 1, err, - sizeof(err))) + if ((rvalue->expr_type == EXPR_VARIABLE + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym, 0, 1, err, + sizeof(err))) + || (rvalue->expr_type == EXPR_FUNCTION + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym->result, 0, 1, + err, sizeof(err)))) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); |