From 2dda89a89839310c852c5c1c77de7db59df5b113 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 30 Jul 2012 21:55:41 +0200 Subject: [PATCH] re PR fortran/51081 ([F03] Proc-pointer assignment: Rejects valid internal proc) 2012-07-30 Janus Weil 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 PR fortran/51081 * gfortran.dg/proc_ptr_37.f90: New. From-SVN: r189985 --- gcc/fortran/ChangeLog | 12 ++++++++++++ gcc/fortran/expr.c | 22 ++++++++++++++++++++++ gcc/fortran/gfortran.h | 3 ++- gcc/fortran/primary.c | 11 ++++++++--- gcc/fortran/resolve.c | 15 +++++++-------- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gfortran.dg/proc_ptr_37.f90 | 15 +++++++++++++++ 7 files changed, 71 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_37.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0c0ffe05458..4974cb34d6b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2012-07-30 Janus Weil + + 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-26 Mikael Morin PR fortran/44354 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index cb5e1c66561..f43bc6f8a99 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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e1f2e3c7cc6..063959a8df9 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2805,7 +2805,8 @@ int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); -bool gfc_type_is_extensible (gfc_symbol *sym); +bool gfc_type_is_extensible (gfc_symbol *); +gfc_try gfc_resolve_intrinsic (gfc_symbol *, locus *); /* array.c */ diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e2c3f9917c3..29d278911cd 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2843,13 +2843,18 @@ gfc_match_rvalue (gfc_expr **result) /* Parse functions returning a procptr. */ goto function0; - if (gfc_is_intrinsic (sym, 0, gfc_current_locus) - || gfc_is_intrinsic (sym, 1, gfc_current_locus)) - sym->attr.intrinsic = 1; e = gfc_get_expr (); e->expr_type = EXPR_VARIABLE; e->symtree = symtree; m = gfc_match_varspec (e, 0, false, true); + if (!e->ref && sym->attr.flavor == FL_UNKNOWN + && sym->ts.type == BT_UNKNOWN + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, + sym->name, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } break; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 370e5cd8d36..25c6c8ec00d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -139,7 +139,6 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) static void resolve_symbol (gfc_symbol *sym); -static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ @@ -168,7 +167,7 @@ resolve_procedure_interface (gfc_symbol *sym) resolve_symbol (ifc); if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -1499,8 +1498,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) /* Resolve an intrinsic procedure: Set its function/subroutine attribute, its typespec and formal argument list. */ -static gfc_try -resolve_intrinsic (gfc_symbol *sym, locus *loc) +gfc_try +gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_intrinsic_sym* isym = NULL; const char* symstd; @@ -1588,7 +1587,7 @@ resolve_procedure_expression (gfc_expr* expr) sym = expr->symtree->n.sym; if (sym->attr.intrinsic) - resolve_intrinsic (sym, &expr->where); + gfc_resolve_intrinsic (sym, &expr->where); if (sym->attr.flavor != FL_PROCEDURE || (sym->attr.function && sym->result == sym)) @@ -3064,7 +3063,7 @@ resolve_function (gfc_expr *expr) return SUCCESS; if (sym && sym->attr.intrinsic - && resolve_intrinsic (sym, &expr->where) == FAILURE) + && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) @@ -11884,7 +11883,7 @@ resolve_fl_derived0 (gfc_symbol *sym) resolve_symbol (ifc); if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -12519,7 +12518,7 @@ resolve_symbol (gfc_symbol *sym) representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic - && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) + && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; /* Resolve associate names. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 442aa3fda95..1ee69471d29 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-07-30 Janus Weil + + PR fortran/51081 + * gfortran.dg/proc_ptr_37.f90: New. + 2012-07-30 Ulrich Weigand * lib/target-supports.exp diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 new file mode 100644 index 00000000000..485e76f6648 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_37.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 51081: [F03] Proc-pointer assignment: Rejects valid internal proc +! +! Contributed by Tobias Burnus + +procedure(), pointer :: p1 +procedure(real), pointer :: p2 +p1 => int2 +p2 => scale ! { dg-error "is invalid in procedure pointer assignment" } +contains + subroutine int2() + print *,"..." + end subroutine +end