re PR fortran/30381 ([4.1 only] ISHFTC() constant folding is broken.)

PR 30381
PR 30420
* fortran/simplify.c (convert_mpz_to_unsigned): New function.
	(convert_mpz_to_signed): New function, largely based on
	twos_complement().
	(twos_complement): Removed.
	(gfc_simplify_ibclr): Add conversions to and from an
	unsigned representation before bit-twiddling.
	(gfc_simplify_ibset): Same.
	(gfc_simplify_ishftc): Add checks for overly large
	constant arguments, only check the third argument if
	it's present, carry over high bits into	the result as
	appropriate, and perform the final conversion back to
	a signed representation using the correct sign bit.
	(gfc_simplify_not): Removed unnecessary masking.
* testsuite/gfortran.dg/
	* chkbits.f90: Added IBCLR tests; test calls for
	different integer kinds.
	* ishft.f90: Renamed to ishft_1.f90...
	* ishft_1.f90: ...Renamed from ishft.f90.
	* ishft_2.f90: New test.
	* ishft_3.f90: New test.

From-SVN: r120634

7 files changed, 149 insertions, 54 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5ea277e..8cf0bc3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,21 @@
+2007-01-09  Brooks Moses  <brooks.moses@codesourcery.com>
+
+	PR 30381
+	PR 30420
+	* simplify.c (convert_mpz_to_unsigned): New function.
+	(convert_mpz_to_signed): New function, largely based on
+	twos_complement().
+	(twos_complement): Removed.
+	(gfc_simplify_ibclr): Add conversions to and from an
+	unsigned representation before bit-twiddling.
+	(gfc_simplify_ibset): Same.
+	(gfc_simplify_ishftc): Add checks for overly large
+	constant arguments, only check the third argument if
+	it's present, carry over high bits into	the result as
+	appropriate, and perform the final conversion back to
+	a signed representation using the correct sign bit.
+	(gfc_simplify_not): Removed unnecessary masking.
+
 2007-01-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/30408
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 8ecabf0..82005f1 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -154,20 +154,56 @@ get_kind (bt type, gfc_expr * k, const char *name, int default_kind)
 }
 
 
-/* Checks if X, which is assumed to represent a two's complement
-   integer of binary width BITSIZE, has the signbit set.  If so, makes 
-   X the corresponding negative number.  */
+/* Converts an mpz_t signed variable into an unsigned one, assuming
+   two's complement representations and a binary width of bitsize.
+   The conversion is a no-op unless x is negative; otherwise, it can
+   be accomplished by masking out the high bits.  */
 
 static void
-twos_complement (mpz_t x, int bitsize)
+convert_mpz_to_unsigned (mpz_t x, int bitsize)
 {
   mpz_t mask;
 
+  if (mpz_sgn (x) < 0)
+    {
+      /* Confirm that no bits above the signed range are unset.  */
+      gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
+
+      mpz_init_set_ui (mask, 1);
+      mpz_mul_2exp (mask, mask, bitsize);
+      mpz_sub_ui (mask, mask, 1);
+
+      mpz_and (x, x, mask);
+
+      mpz_clear (mask);
+    }
+  else
+    {
+      /* Confirm that no bits above the signed range are set.  */
+      gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
+    }
+}
+
+
+/* Converts an mpz_t unsigned variable into a signed one, assuming
+   two's complement representations and a binary width of bitsize.
+   If the bitsize-1 bit is set, this is taken as a sign bit and
+   the number is converted to the corresponding negative number.  */
+
+
+static void
+convert_mpz_to_signed (mpz_t x, int bitsize)
+{
+  mpz_t mask;
+
+  /* Confirm that no bits above the unsigned range are set.  */
+  gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
+
   if (mpz_tstbit (x, bitsize - 1) == 1)
     {
-      mpz_init_set_ui(mask, 1);
-      mpz_mul_2exp(mask, mask, bitsize);
-      mpz_sub_ui(mask, mask, 1);
+      mpz_init_set_ui (mask, 1);
+      mpz_mul_2exp (mask, mask, bitsize);
+      mpz_sub_ui (mask, mask, 1);
 
       /* We negate the number by hand, zeroing the high bits, that is
         make it the corresponding positive number, and then have it
@@ -1253,7 +1289,14 @@ gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y)
 
   result = gfc_copy_expr (x);
 
+  convert_mpz_to_unsigned (result->value.integer,
+			   gfc_integer_kinds[k].bit_size);
+
   mpz_clrbit (result->value.integer, pos);
+
+  convert_mpz_to_signed (result->value.integer,
+			 gfc_integer_kinds[k].bit_size);
+
   return range_check (result, "IBCLR");
 }
 
@@ -1289,9 +1332,8 @@ gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z)
 
   if (pos + len > bitsize)
     {
-      gfc_error
-	("Sum of second and third arguments of IBITS exceeds bit size "
-	 "at %L", &y->where);
+      gfc_error ("Sum of second and third arguments of IBITS exceeds "
+		 "bit size at %L", &y->where);
       return &gfc_bad_expr;
     }
 
@@ -1353,9 +1395,13 @@ gfc_simplify_ibset (gfc_expr * x, gfc_expr * y)
 
   result = gfc_copy_expr (x);
 
+  convert_mpz_to_unsigned (result->value.integer,
+			   gfc_integer_kinds[k].bit_size);
+
   mpz_setbit (result->value.integer, pos);
 
-  twos_complement (result->value.integer, gfc_integer_kinds[k].bit_size);
+  convert_mpz_to_signed (result->value.integer,
+			 gfc_integer_kinds[k].bit_size);
 
   return range_check (result, "IBSET");
 }
@@ -1786,7 +1832,7 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
 	}
     }
 
-  twos_complement (result->value.integer, isize);
+  convert_mpz_to_signed (result->value.integer, isize);
 
   gfc_free (bits);
   return result;
@@ -1797,7 +1843,7 @@ gfc_expr *
 gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 {
   gfc_expr *result;
-  int shift, ashift, isize, delta, k;
+  int shift, ashift, isize, ssize, delta, k;
   int i, *bits;
 
   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
@@ -1810,45 +1856,60 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
     }
 
   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+  isize = gfc_integer_kinds[k].bit_size;
 
   if (sz != NULL)
     {
-      if (gfc_extract_int (sz, &isize) != NULL || isize < 0)
+      if (sz->expr_type != EXPR_CONSTANT)
+        return NULL;
+
+      if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
 	{
 	  gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
 	  return &gfc_bad_expr;
 	}
+
+      if (ssize > isize)
+	{
+	  gfc_error ("Magnitude of third argument of ISHFTC exceeds "
+		     "BIT_SIZE of first argument at %L", &s->where);
+	  return &gfc_bad_expr;
+	}
     }
   else
-    isize = gfc_integer_kinds[k].bit_size;
+    ssize = isize;
 
   if (shift >= 0)
     ashift = shift;
   else
     ashift = -shift;
 
-  if (ashift > isize)
+  if (ashift > ssize)
     {
-      gfc_error
-	("Magnitude of second argument of ISHFTC exceeds third argument "
-	 "at %L", &s->where);
+      if (sz != NULL)
+	gfc_error ("Magnitude of second argument of ISHFTC exceeds "
+		   "third argument at %L", &s->where);
+      else
+	gfc_error ("Magnitude of second argument of ISHFTC exceeds "
+		   "BIT_SIZE of first argument at %L", &s->where);
       return &gfc_bad_expr;
     }
 
   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
 
+  mpz_set (result->value.integer, e->value.integer);
+
   if (shift == 0)
-    {
-      mpz_set (result->value.integer, e->value.integer);
-      return result;
-    }
+    return result;
 
-  bits = gfc_getmem (isize * sizeof (int));
+  convert_mpz_to_unsigned (result->value.integer, isize);
 
-  for (i = 0; i < isize; i++)
+  bits = gfc_getmem (ssize * sizeof (int));
+
+  for (i = 0; i < ssize; i++)
     bits[i] = mpz_tstbit (e->value.integer, i);
 
-  delta = isize - ashift;
+  delta = ssize - ashift;
 
   if (shift > 0)
     {
@@ -1860,7 +1921,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	    mpz_setbit (result->value.integer, i + shift);
 	}
 
-      for (i = delta; i < isize; i++)
+      for (i = delta; i < ssize; i++)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i - delta);
@@ -1878,7 +1939,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	    mpz_setbit (result->value.integer, i + delta);
 	}
 
-      for (i = ashift; i < isize; i++)
+      for (i = ashift; i < ssize; i++)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i + shift);
@@ -1887,7 +1948,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	}
     }
 
-  twos_complement (result->value.integer, isize);
+  convert_mpz_to_signed (result->value.integer, isize);
 
   gfc_free (bits);
   return result;
@@ -2580,8 +2641,6 @@ gfc_expr *
 gfc_simplify_not (gfc_expr * e)
 {
   gfc_expr *result;
-  int i;
-  mpz_t mask;
 
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -2590,21 +2649,6 @@ gfc_simplify_not (gfc_expr * e)
 
   mpz_com (result->value.integer, e->value.integer);
 
-  /* Because of how GMP handles numbers, the result must be ANDed with
-     a mask.  For radices <> 2, this will require change.  */
-
-  i = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
-
-  mpz_init (mask);
-  mpz_add (mask, gfc_integer_kinds[i].huge, gfc_integer_kinds[i].huge);
-  mpz_add_ui (mask, mask, 1);
-
-  mpz_and (result->value.integer, result->value.integer, mask);
-
-  twos_complement (result->value.integer, gfc_integer_kinds[i].bit_size);
-
-  mpz_clear (mask);
-
   return range_check (result, "NOT");
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0a6ffa2..71488e5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,14 @@
 2007-01-09  Brooks Moses  <brooks.moses@codesourcery.com>
 
+	* gfortran.dg/chkbits.f90: Added IBCLR tests; test calls
+	for different integer kinds.
+	* gfortran.dg/ishft.f90: Renamed to ishft_1.f90...
+	* gfortran.dg/ishft_1.f90: ...Renamed from ishft.f90.
+	* gfortran.dg/ishft_2.f90: New test.
+	* gfortran.dg/ishft_3.f90: New test.
+
+2007-01-09  Brooks Moses  <brooks.moses@codesourcery.com>
+
 	* gfortran.dg/altreturn_2.f90: Removed executable bit.
 
 2007-01-09  Zdenek Dvorak <dvorakz@suse.cz>
diff --git a/gcc/testsuite/gfortran.dg/chkbits.f90 b/gcc/testsuite/gfortran.dg/chkbits.f90
index 19ab5c7..4652439 100644
--- a/gcc/testsuite/gfortran.dg/chkbits.f90
+++ b/gcc/testsuite/gfortran.dg/chkbits.f90
@@ -11,16 +11,23 @@ program chkbits
   integer(kind=4) i4
   integer(kind=8) i8
 
-  i1 = ibset(2147483647,bit_size(i4)-1)
-  i2 = ibset(2147483647,bit_size(i4)-1)
-  i4 = ibset(2147483647,bit_size(i4)-1)
-  i8 = ibset(2147483647,bit_size(i4)-1)
+  i1 = ibset(huge(0_1), bit_size(i1)-1)
+  i2 = ibset(huge(0_2), bit_size(i2)-1)
+  i4 = ibset(huge(0_4), bit_size(i4)-1)
+  i8 = ibset(huge(0_8), bit_size(i8)-1)
   if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) call abort
 
-  i1 = not(0)
-  i2 = not(0)
-  i4 = not(0)
-  i8 = not(0)
+  i1 = ibclr(-1_1, bit_size(i1)-1)
+  i2 = ibclr(-1_2, bit_size(i2)-1)
+  i4 = ibclr(-1_4, bit_size(i4)-1)
+  i8 = ibclr(-1_8, bit_size(i8)-1)
+  if (i1 /= huge(0_1) .or. i2 /= huge(0_2)) call abort
+  if (i4 /= huge(0_4) .or. i8 /= huge(0_8)) call abort
+
+  i1 = not(0_1)
+  i2 = not(0_2)
+  i4 = not(0_4)
+  i8 = not(0_8)
   if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) call abort
 
 end program chkbits
diff --git a/gcc/testsuite/gfortran.dg/ishft.f90 b/gcc/testsuite/gfortran.dg/ishft_1.f90
index 88edd30..88edd30 100644
--- a/gcc/testsuite/gfortran.dg/ishft.f90
+++ b/gcc/testsuite/gfortran.dg/ishft_1.f90
diff --git a/gcc/testsuite/gfortran.dg/ishft_2.f90 b/gcc/testsuite/gfortran.dg/ishft_2.f90
new file mode 100644
index 0000000..96acf0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ishft_2.f90
@@ -0,0 +1,6 @@
+! { dg-do run }
+program ishft_2
+  if ( ishftc(3, 2, 3) /= 5 ) call abort()
+  if ( ishftc(256+3, 2, 3) /= 256+5 ) call abort()
+  if ( ishftc(1_4, 31)+1 /= -huge(1_4) ) call abort()
+end program
diff --git a/gcc/testsuite/gfortran.dg/ishft_3.f90 b/gcc/testsuite/gfortran.dg/ishft_3.f90
new file mode 100644
index 0000000..fa3938e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ishft_3.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+program ishft_3
+  integer i, j
+  write(*,*) ishftc( 3, 2, 3 )
+  write(*,*) ishftc( 3, 2, i )
+  write(*,*) ishftc( 3, i, j )
+  write(*,*) ishftc( 3, 128 )     ! { dg-error "exceeds BIT_SIZE of first" }
+  write(*,*) ishftc( 3, 0, 128 )  ! { dg-error "exceeds BIT_SIZE of first" }
+  write(*,*) ishftc( 3, 0, 0 )    ! { dg-error "Invalid third argument" }
+  write(*,*) ishftc( 3, 3, 2 )    ! { dg-error "exceeds third argument" }
+end program