From patchwork Fri Aug 5 20:38:44 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 108729 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 B9817B6F76 for ; Sat, 6 Aug 2011 06:39:07 +1000 (EST) Received: (qmail 24966 invoked by alias); 5 Aug 2011 20:39:05 -0000 Received: (qmail 24949 invoked by uid 22791); 5 Aug 2011 20:39:04 -0000 X-SWARE-Spam-Status: No, hits=-1.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, 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; Fri, 05 Aug 2011 20:38:48 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 08A7512436; Fri, 5 Aug 2011 22:38:47 +0200 (CEST) Received: from [192.168.0.197] (xdsl-78-35-163-27.netcologne.de [78.35.163.27]) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA id B84BD11E75; Fri, 5 Aug 2011 22:38:45 +0200 (CEST) Message-ID: <4E3C54D4.10401@netcologne.de> Date: Fri, 05 Aug 2011 22:38:44 +0200 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.17) Gecko/20110414 SUSE/3.1.10 Thunderbird/3.1.10 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" , gcc-patches Subject: [patch, fortran] PR 37721, warn about target > source in TRANSFER 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, the attached patch fixes PR 37721 by moving the check for TRANSFER size mismatches to checking, away from simplification. That means that it is possible to check character MOLDs whose size is constant, but which aren't constant themselves. I added the extra argument to gfc_target_interpret_expr because for a TRANSFER, we want a binary copy and not a conversion between wide and normal characters. Regression-tested. OK for trunk? Thomas 2011-08-05 Thomas Koenig PR fortran/37221 * gfortran.h (gfc_calculate_transfer_sizes): Add prototype. * target-memory.h (gfc_target_interpret_expr): Add boolean argument wether to convert wide characters. * target-memory.c (gfc_target_expr_size): Also return length of characters for non-constant expressions if these can be determined from the cl. (interpret_array): Add argument for gfc_target_interpret_expr. (gfc_interpret_derived): Likewise. (gfc_target_interpret_expr): Likewise. * check.c: Include target-memory.h. (gfc_calculate_transfer_sizes): New function. (gfc_check_transfer): When -Wsurprising is in force, calculate sizes and warn if result is larger than size (check moved from gfc_simplify_transfer). * simplify.c (gfc_simplify_transfer): Use gfc_calculate_transfer_sizes. Remove warning. 2011-08-05 Thomas Koenig PR fortran/37221 * gfortran.dg/transfer_check_2.f90: New test case. ! { dg-do compile } ! { dg-options "-Wsurprising" } ! PR 37221 - also warn about too-long MOLD for TRANSFER if not simplifying. ! Test case based on contribution by Tobias Burnus. program main character(len=10) :: str integer :: i str = transfer(65+66*2**8+67*2**16+68*2**24,str) ! { dg-warning "has partly undefined result" } write (*,*) str(1:4) i = 65+66*2**8+67*2**16+68*2**24 str = transfer(i,str) ! { dg-warning "has partly undefined result" } write (*,*) str(1:4) str = transfer(i,str(1:4)) write (*,*) str(1:4) end program Index: gfortran.h =================================================================== --- gfortran.h (Revision 176933) +++ gfortran.h (Arbeitskopie) @@ -2884,6 +2884,8 @@ int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); /* check.c */ gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); +gfc_try gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*, + size_t*, size_t*, size_t*); /* class.c */ void gfc_add_component_ref (gfc_expr *, const char *); Index: target-memory.c =================================================================== --- target-memory.c (Revision 176933) +++ target-memory.c (Arbeitskopie) @@ -103,16 +103,20 @@ gfc_target_expr_size (gfc_expr *e) case BT_LOGICAL: return size_logical (e->ts.kind); case BT_CHARACTER: - if (e->expr_type == EXPR_SUBSTRING && e->ref) - { - int start, end; + if (e->expr_type == EXPR_CONSTANT) + return size_character (e->value.character.length, e->ts.kind); + else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT + && e->ts.u.cl->length->ts.type == BT_INTEGER) + { + int length; - gfc_extract_int (e->ref->u.ss.start, &start); - gfc_extract_int (e->ref->u.ss.end, &end); - return size_character (MAX(end - start + 1, 0), e->ts.kind); - } + gfc_extract_int (e->ts.u.cl->length, &length); + return size_character (length, e->ts.kind); + } else - return size_character (e->value.character.length, e->ts.kind); + return 0; + case BT_HOLLERITH: return e->representation.length; case BT_DERIVED: @@ -330,7 +334,8 @@ interpret_array (unsigned char *buffer, size_t buf gfc_constructor_append_expr (&base, e, &result->where); - ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); + ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, + true); } result->value.constructor = base; @@ -456,7 +461,7 @@ gfc_interpret_derived (unsigned char *buffer, size e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where); c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); c->n.component = cmp; - gfc_target_interpret_expr (buffer, buffer_size, e); + gfc_target_interpret_expr (buffer, buffer_size, e, true); e->ts.is_iso_c = 1; return int_size_in_bytes (ptr_type_node); } @@ -506,7 +511,7 @@ gfc_interpret_derived (unsigned char *buffer, size gcc_assert (ptr % 8 == 0); ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); - gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); + gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true); } return int_size_in_bytes (type); @@ -516,7 +521,7 @@ gfc_interpret_derived (unsigned char *buffer, size /* Read a binary buffer to a constant expression. */ int gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, - gfc_expr *result) + gfc_expr *result, bool convert_widechar) { if (result->expr_type == EXPR_ARRAY) return interpret_array (buffer, buffer_size, result); @@ -562,7 +567,7 @@ gfc_target_interpret_expr (unsigned char *buffer, break; } - if (result->ts.type == BT_CHARACTER) + if (result->ts.type == BT_CHARACTER && convert_widechar) result->representation.string = gfc_widechar_to_char (result->value.character.string, result->value.character.length); Index: target-memory.h =================================================================== --- target-memory.h (Revision 176933) +++ target-memory.h (Arbeitskopie) @@ -41,7 +41,7 @@ int gfc_interpret_complex (int, unsigned char *, s int gfc_interpret_logical (int, unsigned char *, size_t, int *); int gfc_interpret_character (unsigned char *, size_t, gfc_expr *); int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *); -int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *); +int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *, bool); /* Merge overlapping equivalence initializers for trans-common.c. */ size_t gfc_merge_initializers (gfc_typespec, gfc_expr *, Index: check.c =================================================================== --- check.c (Revision 176933) +++ check.c (Arbeitskopie) @@ -32,6 +32,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "intrinsic.h" #include "constructor.h" +#include "target-memory.h" /* Make sure an expression is a scalar. */ @@ -3864,11 +3865,68 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr return SUCCESS; } +/* Calculate the sizes for transfer, used by gfc_check_transfer and also + by gfc_simplify_transfer. Return FAILURE if we cannot do so. */ gfc_try -gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, - gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) +gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, + size_t *source_size, size_t *result_size, + size_t *result_length_p) + { + size_t result_elt_size; + mpz_t tmp; + gfc_expr *mold_element; + + if (source->expr_type == EXPR_FUNCTION) + return FAILURE; + + /* Calculate the size of the source. */ + if (source->expr_type == EXPR_ARRAY + && gfc_array_size (source, &tmp) == FAILURE) + return FAILURE; + + *source_size = gfc_target_expr_size (source); + + mold_element = mold->expr_type == EXPR_ARRAY + ? gfc_constructor_first (mold->value.constructor)->expr + : mold; + + /* Determine the size of the element. */ + result_elt_size = gfc_target_expr_size (mold_element); + if (result_elt_size == 0) + return FAILURE; + + if (mold->expr_type == EXPR_ARRAY || mold->rank || size) + { + int result_length; + + if (size) + result_length = (size_t)mpz_get_ui (size->value.integer); + else + { + result_length = *source_size / result_elt_size; + if (result_length * result_elt_size < *source_size) + result_length += 1; + } + + *result_size = result_length * result_elt_size; + if (result_length_p) + *result_length_p = result_length; + } + else + *result_size = result_elt_size; + + return SUCCESS; +} + + +gfc_try +gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) +{ + size_t source_size; + size_t result_size; + if (mold->ts.type == BT_HOLLERITH) { gfc_error ("'MOLD' argument of 'TRANSFER' intrinsic at %L must not be %s", @@ -3888,6 +3946,21 @@ gfc_try return FAILURE; } + if (!gfc_option.warn_surprising) + return SUCCESS; + + /* If we can't calculate the sizes, we cannot check any more. + Return SUCCESS for that case. */ + + if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, NULL) == FAILURE) + return SUCCESS; + + if (source_size < result_size) + gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " + "source size %ld < result size %ld", &source->where, + (long) source_size, (long) result_size); + return SUCCESS; } Index: simplify.c =================================================================== --- simplify.c (Revision 176933) +++ simplify.c (Arbeitskopie) @@ -6028,17 +6028,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr gfc_expr *mold_element; size_t source_size; size_t result_size; - size_t result_elt_size; size_t buffer_size; mpz_t tmp; unsigned char *buffer; + size_t result_length; + if (!gfc_is_constant_expr (source) || (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) || !gfc_is_constant_expr (size)) return NULL; - if (source->expr_type == EXPR_FUNCTION) + if (gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, &result_length) == FAILURE) return NULL; /* Calculate the size of the source. */ @@ -6064,45 +6066,17 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr result->value.character.length = mold_element->value.character.length; /* Set the number of elements in the result, and determine its size. */ - result_elt_size = gfc_target_expr_size (mold_element); - if (result_elt_size == 0) - { - gfc_free_expr (result); - return NULL; - } if (mold->expr_type == EXPR_ARRAY || mold->rank || size) { - int result_length; - result->expr_type = EXPR_ARRAY; result->rank = 1; - - if (size) - result_length = (size_t)mpz_get_ui (size->value.integer); - else - { - result_length = source_size / result_elt_size; - if (result_length * result_elt_size < source_size) - result_length += 1; - } - result->shape = gfc_get_shape (1); mpz_init_set_ui (result->shape[0], result_length); - - result_size = result_length * result_elt_size; } else - { - result->rank = 0; - result_size = result_elt_size; - } + result->rank = 0; - if (gfc_option.warn_surprising && source_size < result_size) - gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: " - "source size %ld < result size %ld", &source->where, - (long) source_size, (long) result_size); - /* Allocate the buffer to store the binary version of the source. */ buffer_size = MAX (source_size, result_size); buffer = (unsigned char*)alloca (buffer_size); @@ -6112,7 +6086,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr gfc_target_encode_expr (source, buffer, buffer_size); /* And read the buffer back into the new expression. */ - gfc_target_interpret_expr (buffer, buffer_size, result); + gfc_target_interpret_expr (buffer, buffer_size, result, false); return result; }