From patchwork Thu Aug 29 22:38:42 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 270990 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "www.sourceware.org", Issuer "StartCom Class 1 Primary Intermediate Server CA" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 88EF62C0091 for ; Fri, 30 Aug 2013 08:39:02 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=VN43WegR2tZNQ/Hal+UGMK0uiU6RVXQkHdR2Ij9TzPuFSy ZE9bAJUT1cpToEM2qFFzLjL+/7iR60eCsooZ+SGSwHy/WnoTI3w+H5D8wFhIp6O4 eehMC0axzDrHywLZlU+v76L06AfKOBNd0WMPg8/gmbFoE8H24DWR2naEg/WOI= 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 :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=qIHVkbhYi/0/D+im3qLQ9KcJias=; b=UxLKmWHIxhX6bmrTp6Uw MUulSmvDSSYAzZ4j+Jv7zK+AMhc4ZAK2f8rtVSIRDgZL7VPWXNI2WTxS6NAkx5xz dygPx+fN2w2sGRDFJNQWvCWyLk1DIB6ESYrTc7RtmxnLIjHHTtI49OgzmseqYro2 PEOBdHYQjQk6ChHXFk1wFWg= Received: (qmail 20022 invoked by alias); 29 Aug 2013 22:38:49 -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 20003 invoked by uid 89); 29 Aug 2013 22:38:49 -0000 Received: from cc-smtpout1.netcologne.de (HELO cc-smtpout1.netcologne.de) (89.1.8.211) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Thu, 29 Aug 2013 22:38:49 +0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-3.4 required=5.0 tests=AWL, BAYES_00, RP_MATCHES_RCVD autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout1.netcologne.de Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout1.netcologne.de (Postfix) with ESMTP id A091812622; Fri, 30 Aug 2013 00:38:44 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id 9163A11D9C; Fri, 30 Aug 2013 00:38:44 +0200 (CEST) Received: from [78.35.143.252] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.0.0) (envelope-from ) id 521fcd74-05d7-7f0000012729-7f000001e6f6-1 for ; Fri, 30 Aug 2013 00:38:44 +0200 Received: from [192.168.0.104] (xdsl-78-35-143-252.netcologne.de [78.35.143.252]) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Fri, 30 Aug 2013 00:38:43 +0200 (CEST) Message-ID: <521FCD72.8020409@netcologne.de> Date: Fri, 30 Aug 2013 00:38:42 +0200 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130801 Thunderbird/17.0.8 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] PR 56519: Reject impure intrinsic subroutines in DO CONCURRENT Hello world, the attached patch rejects impure subroutines, such as RANDOM_NUMBER, within DO CONCURRENT. Regression-tested. OK for trunk? Regards Thomas 2013-08-29 Thomas Koenig PR fortran/PR56519 * gfortran.h: Declare gfc_do_concurrent_flag as extern. * resolve.c: Rename do_concurrent_flag to gfc_do_concurrent_flag. and make non-static. (resolve_function): Use gfc_do_concurrent_flag instead of do_concurrent_flag. (pure_subroutine): Likewise. (resolve_code): Likewise. (resolve_types): Likewise. * intrinsic.c (gfc_intrinsic_sub_interface): Raise error for non-pure intrinsic subroutines within DO CONCURRENT. 2013-08-29 Thomas Koenig PR fortran/PR56519 * gfortran.dg/do_concurrent_3.f90: New test case. Index: gfortran.h =================================================================== --- gfortran.h (Revision 201996) +++ gfortran.h (Arbeitskopie) @@ -2846,6 +2846,7 @@ gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool gfc_type_is_extensible (gfc_symbol *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *); bool gfc_explicit_interface_required (gfc_symbol *, char *, int); +extern int gfc_do_concurrent_flag; /* array.c */ Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 201996) +++ intrinsic.c (Arbeitskopie) @@ -4397,6 +4397,13 @@ gfc_intrinsic_sub_interface (gfc_code *c, int erro c->resolved_sym->attr.elemental = isym->elemental; } + if (gfc_do_concurrent_flag && !isym->pure) + { + gfc_error ("Subroutine call to intrinsic '%s' in DO CONCURRENT " + "block at %L is not PURE", name, &c->loc); + return MATCH_ERROR; + } + if (gfc_pure (NULL) && !isym->pure) { gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name, Index: resolve.c =================================================================== --- resolve.c (Revision 201996) +++ resolve.c (Arbeitskopie) @@ -60,7 +60,7 @@ static code_stack *cs_base = NULL; /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ static int forall_flag; -static int do_concurrent_flag; +int gfc_do_concurrent_flag; /* True when we are resolving an expression that is an actual argument to a procedure. */ @@ -2986,11 +2986,11 @@ resolve_function (gfc_expr *expr) forall_flag == 2 ? "mask" : "block"); t = false; } - else if (do_concurrent_flag) + else if (gfc_do_concurrent_flag) { gfc_error ("Reference to non-PURE function '%s' at %L inside a " "DO CONCURRENT %s", name, &expr->where, - do_concurrent_flag == 2 ? "mask" : "block"); + gfc_do_concurrent_flag == 2 ? "mask" : "block"); t = false; } else if (gfc_pure (NULL)) @@ -3059,7 +3059,7 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) if (forall_flag) gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", sym->name, &c->loc); - else if (do_concurrent_flag) + else if (gfc_do_concurrent_flag) gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " "PURE", sym->name, &c->loc); else if (gfc_pure (NULL)) @@ -9629,7 +9629,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { frame.current = code; forall_save = forall_flag; - do_concurrent_save = do_concurrent_flag; + do_concurrent_save = gfc_do_concurrent_flag; if (code->op == EXEC_FORALL) { @@ -9663,9 +9663,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns) to transform the SELECT TYPE into ASSOCIATE first. */ break; case EXEC_DO_CONCURRENT: - do_concurrent_flag = 1; + gfc_do_concurrent_flag = 1; gfc_resolve_blocks (code->block, ns); - do_concurrent_flag = 2; + gfc_do_concurrent_flag = 2; break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; @@ -9684,7 +9684,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; - do_concurrent_flag = do_concurrent_save; + gfc_do_concurrent_flag = do_concurrent_save; if (!gfc_resolve_expr (code->expr2)) t = false; @@ -14404,7 +14404,7 @@ resolve_types (gfc_namespace *ns) } forall_flag = 0; - do_concurrent_flag = 0; + gfc_do_concurrent_flag = 0; gfc_check_interfaces (ns); gfc_traverse_ns (ns, resolve_values);