From patchwork Sat Jun 16 11:01:25 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 165288 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 13633B70EB for ; Sat, 16 Jun 2012 21:02:18 +1000 (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=1340449339; h=Comment: DomainKey-Signature: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=bvxJ0AR FQatAQ3uATPtvuppd4jk=; b=Lq3SQzmtcxZgrSNAUH7Skld/LCGJYrEBHYpWdmR 2R7Vu0Adp79hbZSyGF9dnPPdTUgqeDtv5+ZrwFLQiCfJWk12JQbKeXPvn6KiMQuU LfurM84/1W7n9L0ojvjl7Eec9ARqfo+ItONkcKWA1RbCNLyG6nCJGhnK4gvqE5iE bJLU= 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: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=SQfgr+6WxV13rQWBc7X6EUTAYXsM5dr3JmGGmGozs/+KmuUBn2U/vcLAl/Dfwu fQGJEoeF1mSG6xuRlasAjVVqrqKWY7207/AE7X3tRfQKM/9iSEqk5xG8EbEUnkZv NJ/oHMQbR+FFQenwOzqqw4UDktelDV/6cd6e2HmPdQ2W4=; Received: (qmail 22057 invoked by alias); 16 Jun 2012 11:01:48 -0000 Received: (qmail 22029 invoked by uid 22791); 16 Jun 2012 11:01:46 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 16 Jun 2012 11:01:27 +0000 Received: from [192.168.178.22] (port-92-204-89-101.dynamic.qsc.de [92.204.89.101]) by mx01.qsc.de (Postfix) with ESMTP id D05E83D24F; Sat, 16 Jun 2012 13:01:25 +0200 (CEST) Message-ID: <4FDC6785.2070305@net-b.de> Date: Sat, 16 Jun 2012 13:01:25 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:13.0) Gecko/20120601 Thunderbird/13.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR53692 - Fix passing an absent array to an elemental procedure 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 For details, see PR. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias 2012-06-16 Tobias Burnus PR fortran/53692 * trans-array.c (set_loop_bounds): Don't scalarize via absent optional arrays. * resolve.c (resolve_elemental_actual): Don't stop resolving after printing a warning. 2012-06-16 Tobias Burnus PR fortran/53692 * gfortran.dg/elemental_optional_args_6.f90: New. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 0e78210..f135af1 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4337,6 +4337,7 @@ set_loop_bounds (gfc_loopinfo *loop) bool dynamic[GFC_MAX_DIMENSIONS]; mpz_t *cshape; mpz_t i; + bool nonoptional_arr; loopspec = loop->specloop; @@ -4345,6 +4346,18 @@ set_loop_bounds (gfc_loopinfo *loop) { loopspec[n] = NULL; dynamic[n] = false; + + /* If there are both optional and nonoptional array arguments, scalarize + over the nonoptional; otherwise, it does not matter as then all + (optional) arrays have to be present per F2008, 125.2.12p3(6). */ + + nonoptional_arr = false; + + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP + && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) + nonoptional_arr = true; + /* We use one SS term, and use that to determine the bounds of the loop for this dimension. We try to pick the simplest term. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) @@ -4354,7 +4367,8 @@ set_loop_bounds (gfc_loopinfo *loop) ss_type = ss->info->type; if (ss_type == GFC_SS_SCALAR || ss_type == GFC_SS_TEMP - || ss_type == GFC_SS_REFERENCE) + || ss_type == GFC_SS_REFERENCE + || (ss->info->can_be_null_ref && nonoptional_arr)) continue; info = &ss->info->data.array; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8531318..7d1e281 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1957,7 +1957,6 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) "ELEMENTAL procedure unless there is a non-optional " "argument with the same rank (12.4.1.5)", arg->expr->symtree->n.sym->name, &arg->expr->where); - return FAILURE; } } --- /dev/null 2012-06-16 07:44:03.623809858 +0200 +++ gcc/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90 2012-06-16 12:58:11.000000000 +0200 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! PR fortran/53692 +! +! Check that the nonabsent arrary is used for scalarization: +! Either the NONOPTIONAL one or, if there are none, any array. +! +! Based on a program by Daniel C Chen +! +Program main + implicit none + integer :: arr1(2), arr2(2) + arr1 = [ 1, 2 ] + arr2 = [ 1, 2 ] + call sub1 (arg2=arr2) + + call two () +contains + subroutine sub1 (arg1, arg2) + integer, optional :: arg1(:) + integer :: arg2(:) +! print *, fun1 (arg1, arg2) + if (size (fun1 (arg1, arg2)) /= 2) call abort() ! { dg-warning "is an array and OPTIONAL" } + if (any (fun1 (arg1, arg2) /= [1,2])) call abort() ! { dg-warning "is an array and OPTIONAL" } + end subroutine + + elemental function fun1 (arg1, arg2) + integer,intent(in), optional :: arg1 + integer,intent(in) :: arg2 + integer :: fun1 + fun1 = arg2 + end function +end program + +subroutine two () + implicit none + integer :: arr1(2), arr2(2) + arr1 = [ 1, 2 ] + arr2 = [ 1, 2 ] + call sub2 (arr1, arg2=arr2) +contains + subroutine sub2 (arg1, arg2) + integer, optional :: arg1(:) + integer, optional :: arg2(:) +! print *, fun2 (arg1, arg2) + if (size (fun2 (arg1, arg2)) /= 2) call abort() ! { dg-warning "is an array and OPTIONAL" } + if (any (fun2 (arg1, arg2) /= [1,2])) call abort() ! { dg-warning "is an array and OPTIONAL" } + end subroutine + + elemental function fun2 (arg1,arg2) + integer,intent(in), optional :: arg1 + integer,intent(in), optional :: arg2 + integer :: fun2 + fun2 = arg2 + end function +end subroutine two