From patchwork Thu May 2 15:46:55 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 241031 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 F32212C00B1 for ; Fri, 3 May 2013 01:47:23 +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=NT8tTFnW/9X8zw3qPeVWRnWTCY5mOdFMvlt3FOKrAJQr61 BkqQirI8ubryLAh/S0mT+Dx6+R2lf64m6BdE7Ov6b5OxPGS8DBg9T1Dlq5jjfuxG +0NR/TeHq00yfdELmQiDzbBoux0pavJ1ITGlPeemjZG45aJ2ptVV2XNem9H0A= 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=bUgjsbuYTpq9Rp50So/nWkXxiUQ=; b=SX94w5+mGwAWrUYAvaBq F/gT5g6ssggObnMIo9oLEgFq3wPS0T1ak1N9vj5fStO7XUH1ibxe1eDcqB+GFf9R WEQ8buyiCcqpXxUEHFQG9bCb2JdhRXmhWgAQd3M6DOY+9ZyExu0oif/eoznANM0D qBrT5U4LKSEK02uWFMVswG4= Received: (qmail 10302 invoked by alias); 2 May 2013 15:47:03 -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 10156 invoked by uid 89); 2 May 2013 15:47:02 -0000 X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RCVD_IN_SEMBACKSCATTER autolearn=no version=3.3.1 X-Spam-User: qpsmtpd, 2 recipients Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Thu, 02 May 2013 15:46:59 +0000 Received: from archimedes.net-b.de (port-92-195-76-58.dynamic.qsc.de [92.195.76.58]) by mx01.qsc.de (Postfix) with ESMTP id A51BC3D703; Thu, 2 May 2013 17:46:56 +0200 (CEST) Message-ID: <51828A6F.3090409@net-b.de> Date: Thu, 02 May 2013 17:46:55 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130329 Thunderbird/17.0.5 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR57142 - Fix simplify for SHAPE and SIZE for large arrays X-Virus-Found: No Instead of using the return "size" value directly, the code converted it first to an int and then back into a GMP number. This patch now directly uses the mpz value. Additionally, I added range checks - to print the proper function name (SHAPE instead of SIZE), I split the worker code from the checking code. Build and regtested on x86-64-gnu-linux. OK for the trunk and the 4.7/4.8 branches? Tobias 2013-05-02 Tobias Burnus PR fortran/57142 * simplify.c (gfc_simplify_size): Renamed from simplify_size; fix kind=8 handling. (gfc_simplify_size): New function. (gfc_simplify_shape): Add range check. * resolve.c (resolve_function): Fix handling for ISYM_SIZE. 2013-05-02 Tobias Burnus PR fortran/57142 * gfortran.dg/size_kind_2.f90: New. * gfortran.dg/size_kind_3.f90: New. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6e1f56f..2860e41 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2856,16 +2856,17 @@ resolve_function (gfc_expr *expr) /* Array intrinsics must also have the last upper bound of an assumed size array argument. UBOUND and SIZE have to be excluded from the check if the second argument is anything than a constant. */ for (arg = expr->value.function.actual; arg; arg = arg->next) { if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) + && arg == expr->value.function.actual && arg->next != NULL && arg->next->expr) { if (arg->next->expr->expr_type != EXPR_CONSTANT) break; if (arg->next->name && strncmp (arg->next->name, "kind", 4) == 0) break; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 02505db..815043b 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -33,6 +33,8 @@ along with GCC; see the file COPYING3. If not see gfc_expr gfc_bad_expr; +static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); + /* Note that 'simplification' is not just transforming expressions. For functions that are not simplified at compile time, range @@ -3248,7 +3250,7 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, gfc_expr* dim = result; mpz_set_si (dim->value.integer, d); - result = gfc_simplify_size (array, dim, kind); + result = simplify_size (array, dim, k); gfc_free_expr (dim); if (!result) goto returnNull; @@ -5538,15 +5540,12 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); if (t) - { - mpz_set (e->value.integer, shape[n]); - mpz_clear (shape[n]); - } + mpz_set (e->value.integer, shape[n]); else { mpz_set_ui (e->value.integer, n + 1); - f = gfc_simplify_size (source, e, NULL); + f = simplify_size (source, e, k); gfc_free_expr (e); if (f == NULL) { @@ -5557,23 +5556,30 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) e = f; } + if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) + { + gfc_free_expr (result); + if (t) + gfc_clear_shape (shape, source->rank); + return &gfc_bad_expr; + } + gfc_constructor_append_expr (&result->value.constructor, e, NULL); } + if (t) + gfc_clear_shape (shape, source->rank); + return result; } -gfc_expr * -gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +static gfc_expr * +simplify_size (gfc_expr *array, gfc_expr *dim, int k) { mpz_t size; gfc_expr *return_value; int d; - int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; /* For unary operations, the size of the result is given by the size of the operand. For binary ones, it's the size of the first operand @@ -5603,7 +5609,7 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) replacement = array->value.op.op1; else { - simplified = gfc_simplify_size (array->value.op.op1, dim, kind); + simplified = simplify_size (array->value.op.op1, dim, k); if (simplified) return simplified; @@ -5613,18 +5619,20 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) } /* Try to reduce it directly if possible. */ - simplified = gfc_simplify_size (replacement, dim, kind); + simplified = simplify_size (replacement, dim, k); /* Otherwise, we build a new SIZE call. This is hopefully at least simpler than the original one. */ if (!simplified) - simplified = gfc_build_intrinsic_call (gfc_current_ns, - GFC_ISYM_SIZE, "size", - array->where, 3, - gfc_copy_expr (replacement), - gfc_copy_expr (dim), - gfc_copy_expr (kind)); - + { + gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); + simplified = gfc_build_intrinsic_call (gfc_current_ns, + GFC_ISYM_SIZE, "size", + array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + kind); + } return simplified; } @@ -5643,12 +5651,31 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) return NULL; } - return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size)); + return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + mpz_set (return_value->value.integer, size); mpz_clear (size); + return return_value; } +gfc_expr * +gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *result; + int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + result = simplify_size (array, dim, k); + if (result == NULL || result == &gfc_bad_expr) + return result; + + return range_check (result, "SIZE"); +} + + /* SIZEOF and C_SIZEOF return the size in bytes of an array element multiplied by the array size. */ @@ -5705,7 +5732,8 @@ gfc_simplify_storage_size (gfc_expr *x, mpz_set_si (result->value.integer, gfc_element_size (x)); mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); - return result; + + return range_check (result, "STORAGE_SIZE"); } --- /dev/null 2013-05-02 08:29:57.272077410 +0200 +++ gcc/gcc/testsuite/gfortran.dg/size_kind_2.f90 2013-05-02 15:25:53.765368001 +0200 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/57142 +! +integer :: B(huge(1)+3_8,2_8) +integer(8) :: var1(2), var2, var3 + +var1 = shape(B,kind=8) +var2 = size(B,kind=8) +var3 = size(B,dim=1,kind=8) +end + +! { dg-final { scan-tree-dump "static integer.kind=8. A..\\\[2\\\] = \\\{2147483650, 2\\\};" "original" } } +! { dg-final { scan-tree-dump "var2 = 4294967300;" "original" } } +! { dg-final { scan-tree-dump "var3 = 2147483650;" "original" } } +! { dg-final { cleanup-tree-dump "original" } } --- /dev/null 2013-05-02 08:29:57.272077410 +0200 +++ gcc/gcc/testsuite/gfortran.dg/size_kind_3.f90 2013-05-02 15:22:58.605614924 +0200 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/57142 +! +integer :: B(huge(1)+3_8,2_8) +integer(8) :: var1(2), var2, var3 + +var1 = shape(B) ! { dg-error "SHAPE overflows its kind" } +var2 = size(B) ! { dg-error "SIZE overflows its kind" } +var3 = size(B,dim=1) ! { dg-error "SIZE overflows its kind" } +end