Re: [PATCH] Fold VIEW_CONVERT_EXPR <type, STRING_CST> generated by Fortran FE a lot (PR target/35366)

[Jakub Jelinek <jakub@redhat.com>]

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