+2008-11-12 Jakub Jelinek <jakub@redhat.com>
+
+ PR target/35366
+ * fold-const.c (native_encode_string): New function.
+ (native_encode_expr): Use it for STRING_CST.
+
2008-11-12 DJ Delorie <dj@redhat.com>
* config/m32c/cond.md (cond_to_int peephole2): Don't eliminate the
}
+/* 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
case VECTOR_CST:
return native_encode_vector (expr, ptr, len);
+ case STRING_CST:
+ return native_encode_string (expr, ptr, len);
+
default:
return 0;
}
+2008-11-12 Jakub Jelinek <jakub@redhat.com>
+
+ PR target/35366
+ PR fortran/33759
+ * 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.
+
2008-11-12 Tobias Burnus <burnus@net-b.de>
PR fortran/38065
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)
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);
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)
{
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:
2008-11-12 Jakub Jelinek <jakub@redhat.com>
+ PR target/35366
+ PR fortran/33759
+ * 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.
+
PR c++/35334
* gcc.dg/pr35334.c: New test.
* g++.dg/other/error29.C: New test.
character*4 z2(2,2)
character*80 line
integer i
-logical l
+integer j
real r
character*8 c
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
--- /dev/null
+ ! { 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 }
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
! { 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
projects / platform / upstream / gcc.git / commitdiff