diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2012-07-30 21:55:41 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2012-07-30 21:55:41 +0200 |
| commit | 2dda89a89839310c852c5c1c77de7db59df5b113 (patch) | |
| tree | 967f294cebb894be86bd2873e725cb5adf332b9b /gcc/fortran/expr.c | |
| parent | caf624554c8dd1bc1bf582a9ff38dec033fba5b3 (diff) | |
| download | gcc-2dda89a89839310c852c5c1c77de7db59df5b113.zip gcc-2dda89a89839310c852c5c1c77de7db59df5b113.tar.gz gcc-2dda89a89839310c852c5c1c77de7db59df5b113.tar.bz2 | |
re PR fortran/51081 ([F03] Proc-pointer assignment: Rejects valid internal proc)
2012-07-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/51081
* gfortran.h (gfc_resolve_intrinsic): Add prototype.
* expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed.
Check for invalid intrinsics.
* primary.c (gfc_match_rvalue): Check for intrinsics came too early.
Set procedure flavor if appropriate.
* resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic.
(resolve_procedure_interface,resolve_procedure_expression,
resolve_function,resolve_fl_derived0,resolve_symbol): Ditto.
2012-07-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/51081
* gfortran.dg/proc_ptr_37.f90: New.
From-SVN: r189985
Diffstat (limited to 'gcc/fortran/expr.c')
| -rw-r--r-- | gcc/fortran/expr.c | 22 |
1 files changed, 22 insertions, 0 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cb5e1c6..f43bc6f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3421,6 +3421,21 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) &rvalue->where); return FAILURE; } + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) + { + /* Check for intrinsics. */ + gfc_symbol *sym = rvalue->symtree->n.sym; + if (!sym->attr.intrinsic + && !(sym->attr.contained || sym->attr.use_assoc + || sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) + && (gfc_is_intrinsic (sym, 0, sym->declared_at) + || gfc_is_intrinsic (sym, 1, sym->declared_at))) + { + sym->attr.intrinsic = 1; + gfc_resolve_intrinsic (sym, &rvalue->where); + attr = gfc_expr_attr (rvalue); + } + } if (attr.abstract) { gfc_error ("Abstract interface '%s' is invalid " @@ -3444,6 +3459,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) "at %L", rvalue->symtree->name, &rvalue->where) == FAILURE) return FAILURE; + if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, + attr.subroutine) == 0) + { + gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " + "assignment", rvalue->symtree->name, &rvalue->where); + return FAILURE; + } } /* Check for F08:C730. */ if (attr.elemental && !attr.intrinsic) |