[PATCH] Fold VIEW_CONVERT_EXPR <type, STRING_CST> generated by Fortran FE a lot (PR target/35366)
Jakub Jelinek
jakub@redhat.com
Wed Nov 12 12:03:00 GMT 2008
Hi!
On Tue, Nov 11, 2008 at 11:34:29PM +0100, Tobias Burnus wrote:
> Brooks Moses wrote:
> + gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
> + " at %L has undefined result", &expr->where);
> > The warning could perhaps be edited a little, too, to reflect that the
> > user isn't necessarily thinking of the input as an integer. Maybe:
> > "Cannot assign value with bitwise representation other than 0x0 or 0x1
> > to LOGICAL at %L".
>
> I find the original string clearer than especially the "0x0 or 0x1".
So, here is an updated patch, which
1) handles transfer (transfer (x, .false.), something) the same way
as transfer (transfer (x, 0), something) (i.e. uses INTEGER_TYPE
of the same mode as the BOOLEAN_TYPE that was used previously)
2) testcases have been updated
3) no checking for INTEGER_CST result from fold_buil1 (V_C_E, ...),
it just uses integer_zerop and integer_onep.
The middle-end side hasn't changed.
Ok for trunk?
2008-11-11 Jakub Jelinek <jakub@redhat.com>
PR target/35366
* fold-const.c (native_encode_string): New function.
(native_encode_expr): Use it for STRING_CST.
* trans-const.c (gfc_conv_constant_to_tree): Warn when
converting an integer outside of LOGICAL's range to
LOGICAL.
* trans-intrinsic.c (gfc_conv_intrinsic_function,
gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_transfer):
Use INTEGER_TYPE instead of BOOLEAN_TYPE for TRANSFER as
argument of another TRANSFER.
* gfortran.dg/hollerith.f90: Don't assume a 32-bit value
stored into logical variable will be preserved.
* gfortran.dg/transfer_simplify_4.f90: Remove undefined
cases. Run at all optimization levels. Add a couple of
new tests.
* gfortran.dg/hollerith5.f90: New test.
* gfortran.dg/hollerith_legacy.f90: Add dg-warning.
--- gcc/fold-const.c.jj 2008-11-12 00:43:54.000000000 +0100
+++ gcc/fold-const.c 2008-11-12 11:09:40.000000000 +0100
@@ -7315,6 +7315,37 @@ native_encode_vector (const_tree expr, u
}
+/* Subroutine of native_encode_expr. Encode the STRING_CST
+ specified by EXPR into the buffer PTR of length LEN bytes.
+ Return the number of bytes placed in the buffer, or zero
+ upon failure. */
+
+static int
+native_encode_string (const_tree expr, unsigned char *ptr, int len)
+{
+ tree type = TREE_TYPE (expr);
+ HOST_WIDE_INT total_bytes;
+
+ if (TREE_CODE (type) != ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (type)) != INTEGER_TYPE
+ || GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) != BITS_PER_UNIT
+ || !host_integerp (TYPE_SIZE_UNIT (type), 0))
+ return 0;
+ total_bytes = tree_low_cst (TYPE_SIZE_UNIT (type), 0);
+ if (total_bytes > len)
+ return 0;
+ if (TREE_STRING_LENGTH (expr) < total_bytes)
+ {
+ memcpy (ptr, TREE_STRING_POINTER (expr), TREE_STRING_LENGTH (expr));
+ memset (ptr + TREE_STRING_LENGTH (expr), 0,
+ total_bytes - TREE_STRING_LENGTH (expr));
+ }
+ else
+ memcpy (ptr, TREE_STRING_POINTER (expr), total_bytes);
+ return total_bytes;
+}
+
+
/* Subroutine of fold_view_convert_expr. Encode the INTEGER_CST,
REAL_CST, COMPLEX_CST or VECTOR_CST specified by EXPR into the
buffer PTR of length LEN bytes. Return the number of bytes
@@ -7337,6 +7368,9 @@ native_encode_expr (const_tree expr, uns
case VECTOR_CST:
return native_encode_vector (expr, ptr, len);
+ case STRING_CST:
+ return native_encode_string (expr, ptr, len);
+
default:
return 0;
}
--- gcc/fortran/trans-intrinsic.c.jj 2008-11-12 00:43:54.000000000 +0100
+++ gcc/fortran/trans-intrinsic.c 2008-11-12 11:35:05.000000000 +0100
@@ -3707,6 +3707,14 @@ gfc_conv_intrinsic_array_transfer (gfc_s
mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
+ if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
+ {
+ /* If this TRANSFER is nested in another TRANSFER, use a type
+ that preserves all bits. */
+ if (arg->expr->ts.type == BT_LOGICAL)
+ mold_type = gfc_get_int_type (arg->expr->ts.kind);
+ }
+
if (arg->expr->ts.type == BT_CHARACTER)
{
tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
@@ -3835,6 +3843,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se
arg = arg->next;
type = gfc_typenode_for_spec (&expr->ts);
+ if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
+ {
+ /* If this TRANSFER is nested in another TRANSFER, use a type
+ that preserves all bits. */
+ if (expr->ts.type == BT_LOGICAL)
+ type = gfc_get_int_type (expr->ts.kind);
+ }
if (expr->ts.type == BT_CHARACTER)
{
@@ -4750,20 +4765,30 @@ gfc_conv_intrinsic_function (gfc_se * se
break;
case GFC_ISYM_TRANSFER:
- if (se->ss)
+ if (se->ss && se->ss->useflags)
{
- if (se->ss->useflags)
- {
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- break;
- }
- else
- gfc_conv_intrinsic_array_transfer (se, expr);
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
}
else
- gfc_conv_intrinsic_transfer (se, expr);
+ {
+ /* Ensure double transfer through LOGICAL preserves all
+ the needed bits. */
+ gfc_expr *source = expr->value.function.actual->expr;
+ if (source->expr_type == EXPR_FUNCTION
+ && source->value.function.esym == NULL
+ && source->value.function.isym != NULL
+ && source->value.function.isym->id == GFC_ISYM_TRANSFER
+ && source->ts.type == BT_LOGICAL
+ && expr->ts.type != source->ts.type)
+ source->value.function.name = "__transfer_in_transfer";
+
+ if (se->ss)
+ gfc_conv_intrinsic_array_transfer (se, expr);
+ else
+ gfc_conv_intrinsic_transfer (se, expr);
+ }
break;
case GFC_ISYM_TTYNAM:
--- gcc/fortran/trans-const.c.jj 2008-11-12 00:43:54.000000000 +0100
+++ gcc/fortran/trans-const.c 2008-11-12 11:55:01.000000000 +0100
@@ -281,13 +281,19 @@ gfc_conv_constant_to_tree (gfc_expr * ex
case BT_LOGICAL:
if (expr->representation.string)
- return fold_build1 (VIEW_CONVERT_EXPR,
- gfc_get_logical_type (expr->ts.kind),
- gfc_build_string_const (expr->representation.length,
- expr->representation.string));
+ {
+ tree tmp = fold_build1 (VIEW_CONVERT_EXPR,
+ gfc_get_int_type (expr->ts.kind),
+ gfc_build_string_const (expr->representation.length,
+ expr->representation.string));
+ if (!integer_zerop (tmp) && !integer_onep (tmp))
+ gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
+ " has undefined result at %L", &expr->where);
+ return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
+ }
else
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
- expr->value.logical);
+ expr->value.logical);
case BT_COMPLEX:
if (expr->representation.string)
--- gcc/testsuite/gfortran.dg/transfer_simplify_4.f90.jj 2008-11-12 00:43:54.000000000 +0100
+++ gcc/testsuite/gfortran.dg/transfer_simplify_4.f90 2008-11-12 12:30:46.000000000 +0100
@@ -1,30 +1,39 @@
! { dg-do run }
-! { dg-options "-O0" }
! Tests that the in-memory representation of a transferred variable
! propagates properly.
!
implicit none
integer, parameter :: ip1 = 42
- logical, parameter :: ap1 = transfer(ip1, .true.)
- integer, parameter :: ip2 = transfer(ap1, 0)
+ integer, parameter :: ip2 = transfer(transfer(ip1, .true.), 0)
+ integer :: i, ai(4)
+ logical :: b
- logical :: a
- integer :: i
+ if (ip2 .ne. ip1) call abort ()
i = transfer(transfer(ip1, .true.), 0)
if (i .ne. ip1) call abort ()
- i = transfer(ap1, 0)
- if (i .ne. ip1) call abort ()
-
- a = transfer(ip1, .true.)
- i = transfer(a, 0)
+ i = 42
+ i = transfer(transfer(i, .true.), 0)
if (i .ne. ip1) call abort ()
- i = ip1
- a = transfer(i, .true.)
- i = transfer(a, 0)
- if (i .ne. ip1) call abort ()
+ b = transfer(transfer(.true., 3.1415), .true.)
+ if (.not.b) call abort ()
+
+ b = transfer(transfer(.false., 3.1415), .true.)
+ if (b) call abort ()
+
+ i = 0
+ b = transfer(i, .true.)
+ ! The standard doesn't guarantee here that b will be .false.,
+ ! though in gfortran for all targets it will.
+
+ ai = (/ 42, 42, 42, 42 /)
+ ai = transfer (transfer (ai, .false., 4), ai)
+ if (any(ai .ne. 42)) call abort
+ ai = transfer (transfer ((/ 42, 42, 42, 42 /), &
+& (/ .false., .false., .false., .false. /)), ai)
+ if (any(ai .ne. 42)) call abort
end
--- gcc/testsuite/gfortran.dg/hollerith5.f90.jj 2008-11-12 12:34:26.000000000 +0100
+++ gcc/testsuite/gfortran.dg/hollerith5.f90 2008-11-12 12:40:54.000000000 +0100
@@ -0,0 +1,8 @@
+ ! { dg-do compile }
+ implicit none
+ logical b
+ b = 4Habcd ! { dg-warning "has undefined result" }
+ end
+
+! { dg-warning "Hollerith constant" "const" { target *-*-* } 4 }
+! { dg-warning "Conversion" "conversion" { target *-*-* } 4 }
--- gcc/testsuite/gfortran.dg/hollerith_legacy.f90.jj 2008-09-30 16:56:06.000000000 +0200
+++ gcc/testsuite/gfortran.dg/hollerith_legacy.f90 2008-11-12 12:41:47.000000000 +0100
@@ -21,13 +21,13 @@ data z2/4h(i7),'xxxx','xxxx','xxxx'/
z2 (1,2) = 4h(i8)
i = 4hHell
-l = 4Ho wo
+l = 4Ho wo ! { dg-warning "has undefined result" }
r = 4Hrld!
write (line, '(3A4)') i, l, r
if (line .ne. 'Hello world!') call abort
i = 2Hab
r = 2Hab
-l = 2Hab
+l = 2Hab ! { dg-warning "has undefined result" }
c = 2Hab
write (line, '(3A4, 8A)') i, l, r, c
if (line .ne. 'ab ab ab ab ') call abort
--- gcc/testsuite/gfortran.dg/hollerith.f90.jj 2008-11-12 00:43:54.000000000 +0100
+++ gcc/testsuite/gfortran.dg/hollerith.f90 2008-11-12 12:39:24.000000000 +0100
@@ -8,7 +8,7 @@ character z1(4)
character*4 z2(2,2)
character*80 line
integer i
-logical l
+integer j
real r
character*8 c
@@ -20,15 +20,15 @@ data z2/4h(i7),'xxxx','xxxx','xxxx'/
z2 (1,2) = 4h(i8)
i = 4hHell
-l = 4Ho wo
+j = 4Ho wo
r = 4Hrld!
-write (line, '(3A4)') i, l, r
+write (line, '(3A4)') i, j, r
if (line .ne. 'Hello world!') call abort
i = 2Hab
+j = 2Hab
r = 2Hab
-l = 2Hab
c = 2Hab
-write (line, '(3A4, 8A)') i, l, r, c
+write (line, '(3A4, 8A)') i, j, r, c
if (line .ne. 'ab ab ab ab ') call abort
write(line, '(4A8, "!")' ) x
Jakub
More information about the Fortran
mailing list