From patchwork Sun Dec 14 10:32:14 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 420840 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id A6E5514009B for ; Sun, 14 Dec 2014 21:32:37 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; q=dns; s=default; b=Kq+UggDBOXkymKx9bn gclv5z+w3IBXAlMwZFHNW5Vf16u4oPZ01kFhKB39yz0/cxQBEheiI2Xt0BnG7H82 gcM3VDoESerQ5IkC05dfKVy8e9EooTNTwKrbU1fSWuaxVJMr8YPkDoIouA4s/EcE M9gdWDBpa//dMwOTU94z1IbGw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:in-reply-to:references:date:message-id:subject :from:to:cc:content-type; s=default; bh=0DY60wGasgGjhI/OHxDp089W Vek=; b=mmLwUkFRoOYE38UdIwy9YzDh3N2/5QUTKkNvc0hdEB+E9SCrUHJI2COz tn0cmd5ISYtr6nUSeb8G4gq5pg+Zm+7zAbU23gP/WUl1SeLay5ImUYdl0wQYhNfV LMbwbauslEwuhugVjP4ThUJKV0a8wAN9bCVMHmRpLiRYmFq/JPE= Received: (qmail 12094 invoked by alias); 14 Dec 2014 10:32:22 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 12075 invoked by uid 89); 14 Dec 2014 10:32:21 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-qg0-f45.google.com Received: from mail-qg0-f45.google.com (HELO mail-qg0-f45.google.com) (209.85.192.45) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Sun, 14 Dec 2014 10:32:18 +0000 Received: by mail-qg0-f45.google.com with SMTP id f51so7328224qge.18 for ; Sun, 14 Dec 2014 02:32:15 -0800 (PST) MIME-Version: 1.0 X-Received: by 10.224.22.196 with SMTP id o4mr45997764qab.85.1418553134895; Sun, 14 Dec 2014 02:32:14 -0800 (PST) Received: by 10.96.54.194 with HTTP; Sun, 14 Dec 2014 02:32:14 -0800 (PST) In-Reply-To: References: Date: Sun, 14 Dec 2014 11:32:14 +0100 Message-ID: Subject: Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure From: Janus Weil To: Bernhard Reutner-Fischer Cc: GCC Patches , gfortran >> Regtested on x86_64-unknown-linux-gnu. Ok for trunk? > > s/'%s'/%qs/g > nowadays. Good point, thank you. Updated patch attached. I guess I still new formal approval by someone with reviewer status ... Cheers, Janus Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 218705) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -2746,6 +2746,7 @@ static int pure_function (gfc_expr *e, const char **name) { int pure; + gfc_component *comp; *name = NULL; @@ -2754,8 +2755,14 @@ 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,40 @@ 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 +2850,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,34 +3022,10 @@ 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; - } + if (!check_pure_function(expr)) + t = false; - gfc_unset_implicit_pure (NULL); - } - /* Functions without the RECURSIVE attribution are not allowed to * call themselves. */ if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) @@ -3056,23 +3072,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 +3112,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 +3216,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 +3287,7 @@ found: c->resolved_sym = sym; - pure_subroutine (c, sym); - - return true; + return pure_subroutine (sym, sym->name, &c->loc); } @@ -6036,6 +6061,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 +6102,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; Index: gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 (Revision 218705) +++ gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 (Arbeitskopie) @@ -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 Index: gcc/testsuite/gfortran.dg/stfunc_6.f90 =================================================================== --- gcc/testsuite/gfortran.dg/stfunc_6.f90 (Revision 218705) +++ gcc/testsuite/gfortran.dg/stfunc_6.f90 (Arbeitskopie) @@ -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) Index: gcc/testsuite/gfortran.dg/typebound_operator_4.f03 =================================================================== --- gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Revision 218705) +++ gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (Arbeitskopie) @@ -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