From 0252ef5c6729e472adcd95b49d4a33521d908ee3 Mon Sep 17 00:00:00 2001 From: janus Date: Sun, 14 Dec 2014 12:04:49 +0000 Subject: [PATCH] 2014-12-14 Janus Weil PR fortran/63674 * resolve.c (pure_function): Treat procedure-pointer components. (check_pure_function): New function. (resolve_function): Use it. (pure_subroutine): Return a bool to indicate success and modify arguments. (resolve_generic_s0,resolve_specific_s0,resolve_unknown_s): Use return value of 'pure_subroutine'. (resolve_ppc_call): Call 'pure_subroutine'. (resolve_expr_ppc): Call 'check_pure_function'. 2014-12-14 Janus Weil PR fortran/63674 * gfortran.dg/proc_ptr_comp_39.f90: New. * gfortran.dg/pure_dummy_length_1.f90: Modified error message. * gfortran.dg/stfunc_6.f90: Ditto. * gfortran.dg/typebound_operator_4.f90: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@218717 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 13 +++ gcc/fortran/resolve.c | 114 +++++++++++++-------- gcc/testsuite/ChangeLog | 8 ++ gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 | 32 ++++++ gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 | 2 +- gcc/testsuite/gfortran.dg/stfunc_6.f90 | 2 +- gcc/testsuite/gfortran.dg/typebound_operator_4.f03 | 4 +- 7 files changed, 129 insertions(+), 46 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4d99f18..24bddef 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2014-12-14 Janus Weil + + PR fortran/63674 + * resolve.c (pure_function): Treat procedure-pointer components. + (check_pure_function): New function. + (resolve_function): Use it. + (pure_subroutine): Return a bool to indicate success and modify + arguments. + (resolve_generic_s0,resolve_specific_s0,resolve_unknown_s): Use return + value of 'pure_subroutine'. + (resolve_ppc_call): Call 'pure_subroutine'. + (resolve_expr_ppc): Call 'check_pure_function'. + 2014-12-13 Tobias Burnus Manuel López-Ibáñez diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d47bb7b..6a0a869 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2746,6 +2746,7 @@ static int pure_function (gfc_expr *e, const char **name) { int pure; + gfc_component *comp; *name = NULL; @@ -2754,7 +2755,13 @@ pure_function (gfc_expr *e, const char **name) && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) return pure_stmt_function (e, e->symtree->n.sym); - if (e->value.function.esym) + comp = gfc_get_proc_ptr_comp (e); + if (comp) + { + pure = gfc_pure (comp->ts.interface); + *name = comp->name; + } + else if (e->value.function.esym) { pure = gfc_pure (e->value.function.esym); *name = e->value.function.esym->name; @@ -2801,6 +2808,39 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym) } +/* Check if a non-pure function function is allowed in the current context. */ + +static bool check_pure_function (gfc_expr *e) +{ + const char *name = NULL; + if (!pure_function (e, &name) && name) + { + if (forall_flag) + { + gfc_error ("Reference to non-PURE function %qs at %L inside a " + "FORALL %s", name, &e->where, + forall_flag == 2 ? "mask" : "block"); + return false; + } + else if (gfc_do_concurrent_flag) + { + gfc_error ("Reference to non-PURE function %qs at %L inside a " + "DO CONCURRENT %s", name, &e->where, + gfc_do_concurrent_flag == 2 ? "mask" : "block"); + return false; + } + else if (gfc_pure (NULL)) + { + gfc_error ("Reference to non-PURE function %qs at %L " + "within a PURE procedure", name, &e->where); + return false; + } + gfc_unset_implicit_pure (NULL); + } + return true; +} + + /* Resolve a function call, which means resolving the arguments, then figuring out which entity the name refers to. */ @@ -2809,7 +2849,6 @@ resolve_function (gfc_expr *expr) { gfc_actual_arglist *arg; gfc_symbol *sym; - const char *name; bool t; int temp; procedure_type p = PROC_INTRINSIC; @@ -2982,33 +3021,9 @@ resolve_function (gfc_expr *expr) #undef GENERIC_ID need_full_assumed_size = temp; - name = NULL; - if (!pure_function (expr, &name) && name) - { - if (forall_flag) - { - gfc_error ("Reference to non-PURE function %qs at %L inside a " - "FORALL %s", name, &expr->where, - forall_flag == 2 ? "mask" : "block"); - t = false; - } - else if (gfc_do_concurrent_flag) - { - gfc_error ("Reference to non-PURE function %qs at %L inside a " - "DO CONCURRENT %s", name, &expr->where, - gfc_do_concurrent_flag == 2 ? "mask" : "block"); - t = false; - } - else if (gfc_pure (NULL)) - { - gfc_error ("Function reference to %qs at %L is to a non-PURE " - "procedure within a PURE procedure", name, &expr->where); - t = false; - } - - gfc_unset_implicit_pure (NULL); - } + if (!check_pure_function(expr)) + t = false; /* Functions without the RECURSIVE attribution are not allowed to * call themselves. */ @@ -3056,23 +3071,32 @@ resolve_function (gfc_expr *expr) /************* Subroutine resolution *************/ -static void -pure_subroutine (gfc_code *c, gfc_symbol *sym) +static bool +pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) { if (gfc_pure (sym)) - return; + return true; if (forall_flag) - gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", - sym->name, &c->loc); + { + gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", + name, loc); + return false; + } else if (gfc_do_concurrent_flag) - gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " - "PURE", sym->name, &c->loc); + { + gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " + "PURE", name, loc); + return false; + } else if (gfc_pure (NULL)) - gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name, - &c->loc); + { + gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); + return false; + } gfc_unset_implicit_pure (NULL); + return true; } @@ -3087,7 +3111,8 @@ resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) if (s != NULL) { c->resolved_sym = s; - pure_subroutine (c, s); + if (!pure_subroutine (s, s->name, &c->loc)) + return MATCH_ERROR; return MATCH_YES; } @@ -3190,7 +3215,8 @@ found: gfc_procedure_use (sym, &c->ext.actual, &c->loc); c->resolved_sym = sym; - pure_subroutine (c, sym); + if (!pure_subroutine (sym, sym->name, &c->loc)) + return MATCH_ERROR; return MATCH_YES; } @@ -3260,9 +3286,7 @@ found: c->resolved_sym = sym; - pure_subroutine (c, sym); - - return true; + return pure_subroutine (sym, sym->name, &c->loc); } @@ -6036,6 +6060,9 @@ resolve_ppc_call (gfc_code* c) && comp->ts.interface->formal))) return false; + if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) + return false; + gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); return true; @@ -6074,6 +6101,9 @@ resolve_expr_ppc (gfc_expr* e) if (!update_ppc_arglist (e)) return false; + if (!check_pure_function(e)) + return false; + gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); return true; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a4e64b0..3d96f34 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2014-12-14 Janus Weil + + PR fortran/63674 + * gfortran.dg/proc_ptr_comp_39.f90: New. + * gfortran.dg/pure_dummy_length_1.f90: Modified error message. + * gfortran.dg/stfunc_6.f90: Ditto. + * gfortran.dg/typebound_operator_4.f90: Ditto. + 2014-12-13 Oleg Endo PR target/53513 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 new file mode 100644 index 0000000..cc4096a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 63674: [F03] procedure pointer and non/pure procedure +! +! Contributed by Valery Weber + +program prog + interface + integer function nf() + end function + pure integer function pf() + end function + subroutine ns() + end subroutine + pure subroutine ps() + end subroutine + end interface + type :: t + procedure(nf), nopass, pointer :: nf => NULL() ! non-pure function + procedure(pf), nopass, pointer :: pf => NULL() ! pure function + procedure(ns), nopass, pointer :: ns => NULL() ! non-pure subroutine + procedure(ps), nopass, pointer :: ps => NULL() ! pure subroutine + end type +contains + pure integer function eval(a) + type(t), intent(in) :: a + eval = a%pf() + eval = a%nf() ! { dg-error "Reference to non-PURE function" } + call a%ps() + call a%ns() ! { dg-error "is not PURE" } + end function +end diff --git a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 index c1bc172..b3e75a4 100644 --- a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 +++ b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 @@ -24,6 +24,6 @@ character(*), intent(in) :: string integer(4), intent(in) :: ignore_case integer i - if (end > impure (self)) & ! { dg-error "non-PURE procedure" } + if (end > impure (self)) & ! { dg-error "non-PURE function" } return end function diff --git a/gcc/testsuite/gfortran.dg/stfunc_6.f90 b/gcc/testsuite/gfortran.dg/stfunc_6.f90 index 482d125..413e583 100644 --- a/gcc/testsuite/gfortran.dg/stfunc_6.f90 +++ b/gcc/testsuite/gfortran.dg/stfunc_6.f90 @@ -22,7 +22,7 @@ contains pure integer function u (x) integer,intent(in) :: x - st2 (i) = i * v(i) ! { dg-error "non-PURE procedure" } + st2 (i) = i * v(i) ! { dg-error "non-PURE function" } u = st2(x) end function integer function v (x) diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 index 6ede14e..0a8415f 100644 --- a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 @@ -75,8 +75,8 @@ PURE SUBROUTINE iampure2 () TYPE(myreal) :: x x = 0.0 ! { dg-error "is not PURE" } - x = x + 42.0 ! { dg-error "to a non-PURE procedure" } - x = x .PLUS. 5.0 ! { dg-error "to a non-PURE procedure" } + x = x + 42.0 ! { dg-error "non-PURE function" } + x = x .PLUS. 5.0 ! { dg-error "non-PURE function" } END SUBROUTINE iampure2 PROGRAM main -- 2.7.4