From patchwork Thu Nov 1 12:58:18 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 196189 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]) by ozlabs.org (Postfix) with SMTP id A91ED2C0339 for ; Thu, 1 Nov 2012 23:58:36 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1352379516; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=vMVAIBg guTSxGggipOEhUPDUT6M=; b=ddmShCbR7bpixq1QJMHJZaY+aDcGxcAz9/aMnfu 9cNQednLAsaRDK4ws5RkGJnwmjfI1oaQSFvJ550b53TrAg0UAs4XrxcJV99ZUIT7 4mwxL67WFDz9J9KMWpBbJGSnTc37oezsM/9CSJZeYjDj1eorDWyjftxY5Qu2j7xG nV1w= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=AdTTDpdTBAUNEWk6i0/UCz9p6Ocasa4I6Sn/aKU5dANizpb3br2lZXrrcrxToa GDnUBHDAtZt1zciYq81RnfJFg5zV59S1HSxfWVwgnWb5HI5mPNrag+Aemb/knEQ5 ijJFsuReBsB/K4LstBZKQc9qTf66YHAnrpTRCBuFG4748=; Received: (qmail 12861 invoked by alias); 1 Nov 2012 12:58:30 -0000 Received: (qmail 12836 invoked by uid 22791); 1 Nov 2012 12:58:29 -0000 X-SWARE-Spam-Status: No, hits=-2.1 required=5.0 tests=AWL, BAYES_00, KHOP_RCVD_UNTRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_NO, RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 01 Nov 2012 12:58:22 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 31CFB12816; Thu, 1 Nov 2012 13:58:20 +0100 (CET) Received: from [192.168.0.106] (xdsl-78-35-191-221.netcologne.de [78.35.191.221]) by cc-smtpin1.netcologne.de (Postfix) with ESMTPSA id DFE0B11DB7; Thu, 1 Nov 2012 13:58:18 +0100 (CET) Message-ID: <509271EA.2040003@netcologne.de> Date: Thu, 01 Nov 2012 13:58:18 +0100 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:16.0) Gecko/20121025 Thunderbird/16.0.2 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] PR 30146, errors for INTENT(OUT) and INTENT(INOUT) for DO loop variables 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 Hello world, after the dicsussion on c.l.f, it become clear that passing a DO loop variable to an INTENT(OUT) or INTENT(INOUT) dummy argument is an error. The attached patch throws an error for both cases. I chose to issue the errors as a front-end pass because we cannot check for formal arguments during parsing (where the other checks are implemented). Regression-tested. OK for trunk? Thomas 2012-11-01 Thomas Koenig PR fortran/30146 * frontend-passes.c (do_warn): New function. (do_list): New static variable. (do_size): New static variable. (do_list): New static variable. (gfc_run_passes): Call do_warn. (do_code): New function. (do_function): New function. (gfc_code_walker): Keep track fo DO level. 2012-11-01 Thomas Koenig PR fortran/30146 * gfortran.dg/do_check_6.f90: New test. Index: frontend-passes.c =================================================================== --- frontend-passes.c (Revision 192894) +++ frontend-passes.c (Arbeitskopie) @@ -39,6 +39,7 @@ static bool optimize_trim (gfc_expr *); static bool optimize_lexical_comparison (gfc_expr *); static void optimize_minmaxloc (gfc_expr **); static bool empty_string (gfc_expr *e); +static void do_warn (gfc_namespace *); /* How deep we are inside an argument list. */ @@ -76,12 +77,30 @@ static bool in_omp_workshare; static int iterator_level; -/* Entry point - run all passes for a namespace. So far, only an - optimization pass is run. */ +/* Keep track of DO loop levels. */ +static gfc_code **do_list; +static int do_size, do_level; + +/* Vector of gfc_expr * to keep track of DO loops. */ + +struct my_struct *evec; + +/* Entry point - run all passes for a namespace. */ + void gfc_run_passes (gfc_namespace *ns) { + + /* Warn about dubious DO loops where the index might + change. */ + + do_size = 20; + do_level = 0; + do_list = XNEWVEC(gfc_code *, do_size); + do_warn (ns); + XDELETEVEC (do_list); + if (gfc_option.flag_frontend_optimize) { expr_size = 20; @@ -1225,6 +1244,160 @@ optimize_minmaxloc (gfc_expr **e) mpz_set_ui (a->expr->value.integer, 1); } +/* Callback function for code checking that we do not pass a DO variable to an + INTENT(OUT) or INTENT(INOUT) dummy variable. */ + +static int +do_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co; + int i; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + co = *c; + + switch (co->op) + { + case EXEC_DO: + + /* Grow the temporary storage if necessary. */ + if (do_level >= do_size) + { + do_size = 2 * do_size; + do_list = XRESIZEVEC (gfc_code *, do_list, do_size); + } + + /* Mark the DO loop variable if there is one. */ + if (co->ext.iterator && co->ext.iterator->var) + do_list[do_level] = co; + else + do_list[do_level] = NULL; + break; + + case EXEC_CALL: + f = co->symtree->n.sym->formal; + + /* Withot a formal arglist, there is only unknown INTENT, + which we don't check for. */ + if (f == NULL) + break; + + a = co->ext.actual; + + while (a && f) + { + for (i=0; iext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree + && a->expr->symtree->n.sym == do_sym) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now("Variable '%s' at %L set to undefined value " + "inside loop beginning at %L as INTENT(OUT) " + "argument to subroutine '%s'", do_sym->name, + &a->expr->where, &do_list[i]->loc, + co->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_error_now("Variable '%s' at %L not definable inside loop " + "beginning at %L as INTENT(INOUT) argument to " + "subroutine '%s'", do_sym->name, + &a->expr->where, &do_list[i]->loc, + co->symtree->n.sym->name); + } + } + a = a->next; + f = f->next; + } + break; + + default: + break; + } + return 0; +} + +/* Callback function for functions checking that we do not pass a DO variable + to an INTENt(OUT) or INTENT(INOUT) dummy variable. */ + +static int +do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_expr *expr; + int i; + + expr = *e; + if (expr->expr_type != EXPR_FUNCTION) + return 0; + + /* Intrinsic functions don't modify their arguments. */ + + if (expr->value.function.isym) + return 0; + + f = expr->symtree->n.sym->formal; + + /* Withot a formal arglist, there is only unknown INTENT, + which we don't check for. */ + if (f == NULL) + return 0; + + a = expr->value.function.actual; + + while (a && f) + { + for (i=0; iext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree + && a->expr->symtree->n.sym == do_sym) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now("Variable '%s' at %L set to undefined value " + "inside loop beginning at %L as INTENT(OUT) " + "argument to function '%s'", do_sym->name, + &a->expr->where, &do_list[i]->loc, + expr->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_error_now("Variable '%s' at %L not definable inside loop " + "beginning at %L as INTENT(INOUT) argument to " + "function '%s'", do_sym->name, + &a->expr->where, &do_list[i]->loc, + expr->symtree->n.sym->name); + } + } + a = a->next; + f = f->next; + } + + return 0; +} + +static void +do_warn (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, do_code, do_function, NULL); +} + + #define WALK_SUBEXPR(NODE) \ do \ { \ @@ -1383,6 +1556,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code break; case EXEC_DO: + do_level ++; WALK_SUBEXPR (co->ext.iterator->var); WALK_SUBEXPR (co->ext.iterator->start); WALK_SUBEXPR (co->ext.iterator->end); @@ -1601,6 +1775,9 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t code if (co->op == EXEC_FORALL) forall_level --; + if (co->op == EXEC_DO) + do_level --; + in_omp_workshare = saved_in_omp_workshare; } }