diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d794d14ace0..31696b3f25f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,23 @@ +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-04 Richard Guenther PR fortran/49957 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a95865b9bc6..3d4f4c88378 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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 *dim) 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_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, 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; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index acfa9d4c555..34afae43386 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2896,6 +2896,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 *); diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 79b383a46db..e4ffc3b477f 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -6028,17 +6028,19 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 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,44 +6066,16 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 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; - } - - 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); + result->rank = 0; /* Allocate the buffer to store the binary version of the source. */ buffer_size = MAX (source_size, result_size); @@ -6112,7 +6086,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) 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; } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index b5c90a7b5d4..025bccf0b0c 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -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 buffer_size, gfc_expr *result) 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_t buffer_size, gfc_expr *resu 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_t buffer_size, gfc_expr *resu 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_t buffer_size, gfc_expr *resu /* 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, size_t buffer_size, 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); diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 2a82a88c071..6ebffe86521 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -41,7 +41,7 @@ int gfc_interpret_complex (int, unsigned char *, size_t, mpc_t); 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 *, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 93bf7f92f06..3b5a17fbf19 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-08-05 Thomas Koenig + + PR fortran/37221 + * gfortran.dg/transfer_check_2.f90: New test case. + 2011-08-05 Jan Hubicka PR middle-end/49494 diff --git a/gcc/testsuite/gfortran.dg/transfer_check_2.f90 b/gcc/testsuite/gfortran.dg/transfer_check_2.f90 new file mode 100644 index 00000000000..3f2e1bfb5c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_check_2.f90 @@ -0,0 +1,16 @@ +! { 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 +