+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
#include "gfortran.h"
#include "intrinsic.h"
#include "constructor.h"
+#include "target-memory.h"
/* Make sure an expression is a scalar. */
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",
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;
}
/* 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 *);
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. */
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);
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;
}
case BT_LOGICAL:
return size_logical (e->ts.kind);
case BT_CHARACTER:
- if (e->expr_type == EXPR_SUBSTRING && e->ref)
- {
- int start, end;
-
- 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);
- }
+ 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->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:
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;
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);
}
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);
/* 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);
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);
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 *,
+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
--- /dev/null
+! { 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
+
projects / thirdparty / gcc.git / commitdiff
