re PR fortran/37211 (TRANSFER to characters: Size checking)
2011-08-05 Thomas Koenig <tkoenig@gcc.gnu.org> 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 <tkoenig@gcc.gnu.org> PR fortran/37221 * gfortran.dg/transfer_check_2.f90: New test case. From-SVN: r177486
This commit is contained in:
parent
7cfea2ef26
commit
86dbed7d1b
|
@ -1,3 +1,23 @@
|
|||
2011-08-05 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
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 <rguenther@suse.de>
|
||||
|
||||
PR fortran/49957
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
@ -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 *);
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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 *,
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2011-08-05 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/37221
|
||||
* gfortran.dg/transfer_check_2.f90: New test case.
|
||||
|
||||
2011-08-05 Jan Hubicka <jh@suse.cz>
|
||||
|
||||
PR middle-end/49494
|
||||
|
|
|
@ -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
|
||||
|
Loading…
Reference in New Issue