From patchwork Sun Apr 14 09:57:00 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 236426 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 "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 531B42C00BC for ; Sun, 14 Apr 2013 19:57:14 +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=RbjzW1Qjy/QrK8UcqmXMXtCZGtogNmUPYaWgr6Bj6qyLvB 1NKZLXOA7Uaa39SS8VjcwQKc2355asuBAEUVWCAJzNsTnxFbeIC7Ww/o4rzWkTu5 0n5rSDtrqcIjt47jxeu6hJ+jFJCk4z3G83xPQwSZ87ppsvZ82/BKwbQOuZVGw= 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=xAuwb2k4x5QtX8Vd/1EmJZ2sduI=; b=sNstnamyghD3V4mKzHJB xqRunacKxp67Pqbq3l0qrrqpWwGGdxHDUGPxVsciVIWl2n38x6J4S14wCa3vdPh5 ruDX6HGmV8B4/txFU95D7O2BPJUVENoa4OcRBjpXfw1mW5DfS8Yf5GsITLE0kWJ/ MR8cLJ5HZYGeXrQ14YpaV5o= Received: (qmail 21273 invoked by alias); 14 Apr 2013 09:57:07 -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 21253 invoked by uid 89); 14 Apr 2013 09:57:06 -0000 X-Spam-SWARE-Status: No, score=-1.5 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, KHOP_RCVD_UNTRUST, RCVD_IN_DNSWL_LOW, RCVD_IN_HOSTKARMA_NO, RP_MATCHES_RCVD, TW_FC autolearn=no version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from cc-smtpout3.netcologne.de (HELO cc-smtpout3.netcologne.de) (89.1.8.213) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Sun, 14 Apr 2013 09:57:05 +0000 Received: from cc-smtpin2.netcologne.de (cc-smtpin2.netcologne.de [89.1.8.202]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id 5F709120D7; Sun, 14 Apr 2013 11:57:02 +0200 (CEST) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin2.netcologne.de (Postfix) with ESMTP id 5073C11D77; Sun, 14 Apr 2013 11:57:02 +0200 (CEST) Received: from [78.35.145.49] (helo=cc-smtpin2.netcologne.de) by localhost with ESMTP (eXpurgate 4.0.0) (envelope-from ) id 516a7d6e-1149-7f0000012729-7f000001c5b8-1 for ; Sun, 14 Apr 2013 11:57:02 +0200 Received: from [192.168.0.107] (xdsl-78-35-145-49.netcologne.de [78.35.145.49]) by cc-smtpin2.netcologne.de (Postfix) with ESMTPSA; Sun, 14 Apr 2013 11:57:00 +0200 (CEST) Message-ID: <516A7D6C.7000801@netcologne.de> Date: Sun, 14 Apr 2013 11:57:00 +0200 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130329 Thunderbird/17.0.5 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] Really fix PR 56782 X-Virus-Found: No Hello world, the attached patch completely fixes the regression, PR 56782. Regression-tested. OK for trunk and 4.8? Thomas 2013-04-14 Thomas Koenig PR fortran/56782 * frontend-passes.c (copy_walk_reduction_arg): Do not call the expression walker with callback_reduction. (insert_iterator_function): New function. (callback_reduction): If an iterator is present, call insert_iterator_function and reset the iterator on the original array iterator. 2013-04-08 Thomas Koenig PR fortran/56782 * gfortran.dg/array_constructor_45.f90: New test. * gfortran.dg/array_constructor_46.f90: New test. * gfortran.dg/array_constructor_40.f90: Adjust number of while loops. Index: fortran/frontend-passes.c =================================================================== --- fortran/frontend-passes.c (Revision 197610) +++ fortran/frontend-passes.c (Arbeitskopie) @@ -221,8 +221,47 @@ copy_walk_reduction_arg (gfc_expr *e, gfc_expr *fn fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; } - (void) gfc_expr_walker (&fcn, callback_reduction, NULL); + return fcn; +} +/* Auxiliary function to create function with an an array expression with + iterator argument. */ + +static gfc_expr * +insert_iterator_function (gfc_expr *e, gfc_expr *fn, gfc_iterator *iterator) +{ + gfc_expr *fcn, *new_expr; + gfc_isym_id id; + gfc_constructor_base newbase; + gfc_constructor *new_c; + + newbase = NULL; + new_expr = gfc_get_expr (); + new_expr->expr_type = EXPR_ARRAY; + new_expr->ts = e->ts; + new_expr->where = e->where; + new_expr->rank = 1; + new_c = gfc_constructor_append_expr (&newbase, gfc_copy_expr(e), &(e->where)); + new_c->iterator = iterator; + new_expr->value.constructor = newbase; + + id = fn->value.function.isym->id; + + if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) + fcn = gfc_build_intrinsic_call (current_ns, + fn->value.function.isym->id, + fn->value.function.isym->name, + fn->where, 3, new_expr, + NULL, NULL); + else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) + fcn = gfc_build_intrinsic_call (current_ns, + fn->value.function.isym->id, + fn->value.function.isym->name, + fn->where, 2, new_expr, + NULL); + else + gfc_internal_error ("Illegal id in insert_iterator_function"); + return fcn; } @@ -300,15 +339,19 @@ callback_reduction (gfc_expr **e, int *walk_subtre c = gfc_constructor_first (arg->value.constructor); - /* Don't do any simplififcation if we have - - no element in the constructor or - - only have a single element in the array which contains an - iterator. */ + /* Don't do any simplififcation if we have no element + in the constructor. */ - if (c == NULL || (c->iterator != NULL && gfc_constructor_next (c) == NULL)) + if (c == NULL) return 0; - res = copy_walk_reduction_arg (c->expr, fn); + if (c->iterator) + { + res = insert_iterator_function (c->expr, fn, c->iterator); + c->iterator = NULL; + } + else + res = copy_walk_reduction_arg (c->expr, fn); c = gfc_constructor_next (c); while (c) @@ -320,7 +363,15 @@ callback_reduction (gfc_expr **e, int *walk_subtre new_expr->where = fn->where; new_expr->value.op.op = op; new_expr->value.op.op1 = res; - new_expr->value.op.op2 = copy_walk_reduction_arg (c->expr, fn); + + if (c->iterator) + { + new_expr->value.op.op2 = insert_iterator_function (c->expr, fn, c->iterator); + c->iterator = NULL; + } + else + new_expr->value.op.op2 = copy_walk_reduction_arg (c->expr, fn); + res = new_expr; c = gfc_constructor_next (c); } Index: testsuite/gfortran.dg/array_constructor_40.f90 =================================================================== --- testsuite/gfortran.dg/array_constructor_40.f90 (Revision 197233) +++ testsuite/gfortran.dg/array_constructor_40.f90 (Arbeitskopie) @@ -48,5 +48,5 @@ program main call baz(a,b,res); if (abs(res - 8.1) > 1e-5) call abort end program main -! { dg-final { scan-tree-dump-times "while" 3 "original" } } +! { dg-final { scan-tree-dump-times "while" 5 "original" } } ! { dg-final { cleanup-tree-dump "original" } }