re PR fortran/17568 (ISHFT intrinsic: bogus overflow error)

fortran/
PR fortran/17568
* simplify.c (twos_complement): New function.
(gfc_simplify_ishft, gfc_simplify_ishftc): Revise.

testsuite/
PR fortran/17568
* gfortran.dg/ishft.f90: New test.

From-SVN: r88609

gcc/fortran/ChangeLog

+2004-10-06  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17568
+	* simplify.c (twos_complement): New function.
+	(gfc_simplify_ishft, gfc_simplify_ishftc): Revise.
+
 2004-10-06  Paul Brook  <paul@codesourcery.com>
 
 	* trans-stmt.c (gfc_trans_simple_do): New function.

gcc/fortran/simplify.c

@@ -138,6 +138,38 @@ 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.  */
+
+static void
+twos_complement (mpz_t x, int bitsize)
+{
+  mpz_t mask;
+  char mask_s[bitsize + 1];
+
+  if (mpz_tstbit (x, bitsize - 1) == 1)
+    {
+      /* The mpz_init_set_{u|s}i functions take a long argument, but
+	 the widest integer the target supports might be wider, so we
+	 have to go via an intermediate string.  */
+      memset (mask_s, '1', bitsize);
+      mask_s[bitsize] = '\0';
+      mpz_init_set_str (mask, mask_s, 2);
+
+      /* We negate the number by hand, zeroing the high bits, and then
+	 have it negated by GMP.  */
+      mpz_com (x, x);
+      mpz_add_ui (x, x, 1);
+      mpz_and (x, x, mask);
+
+      mpz_neg (x, x);
+
+      mpz_clear (mask);
+    }
+}
+
+
 /********************** Simplification functions *****************************/
 
 gfc_expr *
@@ -1557,8 +1589,7 @@ gfc_expr *
 gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
 {
   gfc_expr *result;
-  int shift, ashift, isize, k;
-  long e_int;
+  int shift, ashift, isize, k, *bits, i;
 
   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
     return NULL;
@@ -1586,10 +1617,6 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
       return &gfc_bad_expr;
     }
 
-  e_int = mpz_get_si (e->value.integer);
-  if (e_int > INT_MAX || e_int < INT_MIN)
-    gfc_internal_error ("ISHFT: unable to extract integer");
-
   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
 
   if (shift == 0)
@@ -1597,13 +1624,43 @@ gfc_simplify_ishft (gfc_expr * e, gfc_expr * s)
       mpz_set (result->value.integer, e->value.integer);
       return range_check (result, "ISHFT");
     }
+  
+  bits = gfc_getmem (isize * sizeof (int));
+
+  for (i = 0; i < isize; i++)
+    bits[i] = mpz_tstbit (e->value.integer, i);
 
   if (shift > 0)
-    mpz_set_si (result->value.integer, e_int << shift);
+    {
+      for (i = 0; i < shift; i++)
+	mpz_clrbit (result->value.integer, i);
+
+      for (i = 0; i < isize - shift; i++)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i + shift);
+	  else
+	    mpz_setbit (result->value.integer, i + shift);
+	}
+    }
   else
-    mpz_set_si (result->value.integer, e_int >> ashift);
+    {
+      for (i = isize - 1; i >= isize - ashift; i--)
+	mpz_clrbit (result->value.integer, i);
 
-  return range_check (result, "ISHFT");
+      for (i = isize - 1; i >= ashift; i--)
+	{
+	  if (bits[i] == 0)
+	    mpz_clrbit (result->value.integer, i - ashift);
+	  else
+	    mpz_setbit (result->value.integer, i - ashift);
+	}
+    }
+
+  twos_complement (result->value.integer, isize);
+
+  gfc_free (bits);
+  return result;
 }
 
 
@@ -1651,6 +1708,12 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 
   result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
 
+  if (shift == 0)
+    {
+      mpz_set (result->value.integer, e->value.integer);
+      return result;
+    }
+
   bits = gfc_getmem (isize * sizeof (int));
 
   for (i = 0; i < isize; i++)
@@ -1658,20 +1721,13 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 
   delta = isize - ashift;
 
-  if (shift == 0)
-    {
-      mpz_set (result->value.integer, e->value.integer);
-      gfc_free (bits);
-      return range_check (result, "ISHFTC");
-    }
-
-  else if (shift > 0)
+  if (shift > 0)
     {
       for (i = 0; i < delta; i++)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i + shift);
-	  if (bits[i] == 1)
+	  else
 	    mpz_setbit (result->value.integer, i + shift);
 	}
 
@@ -1679,12 +1735,9 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i - delta);
-	  if (bits[i] == 1)
+	  else
 	    mpz_setbit (result->value.integer, i - delta);
 	}
-
-      gfc_free (bits);
-      return range_check (result, "ISHFTC");
     }
   else
     {
@@ -1692,7 +1745,7 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i + delta);
-	  if (bits[i] == 1)
+	  else
 	    mpz_setbit (result->value.integer, i + delta);
 	}
 
@@ -1700,13 +1753,15 @@ gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz)
 	{
 	  if (bits[i] == 0)
 	    mpz_clrbit (result->value.integer, i + shift);
-	  if (bits[i] == 1)
+	  else
 	    mpz_setbit (result->value.integer, i + shift);
 	}
-
-      gfc_free (bits);
-      return range_check (result, "ISHFTC");
     }
+
+  twos_complement (result->value.integer, isize);
+
+  gfc_free (bits);
+  return result;
 }
 
 

gcc/testsuite/ChangeLog

+2004-10-06  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17568
+	* gfortran.dg/ishft.f90: New test.
+	
 2004-10-06  Paul Brook  <paul@codesourcery.com>
 
 	* gfortran.dg/do_1.f90: New test.

gcc/testsuite/gfortran.dg/ishft.f90

+! { dg-do run }
+! verifies basic functioning of the ishft and ishftc intrinsics
+if (ishft (1_1, 0) /= 1) call abort
+if (ishft (1_1, 1) /= 2) call abort
+if (ishft (3_1, 1) /= 6) call abort
+if (ishft (-1_1, 1) /= -2) call abort
+if (ishft (-1_1, -1) /= 127) call abort
+if (ishft (96_1, 2) /= -128_2) call abort
+
+if (ishft (1_2, 0) /= 1) call abort
+if (ishft (1_2, 1) /= 2) call abort
+if (ishft (3_2, 1) /= 6) call abort
+if (ishft (-1_2, 1) /= -2) call abort
+if (ishft (-1_2, -1) /= 32767) call abort
+if (ishft (16384_2 + 8192_2, 2) /= -32768_4) call abort
+
+if (ishft (1_4, 0) /= 1) call abort
+if (ishft (1_4, 1) /= 2) call abort
+if (ishft (3_4, 1) /= 6) call abort
+if (ishft (-1_4, 1) /= -2) call abort
+if (ishft (-1_4, -1) /= 2147483647) call abort
+if (ishft (1073741824_4 + 536870912_4, 2) /= -2147483648_8) call abort
+
+if (ishftc (1_1, 0) /= 1) call abort
+if (ishftc (1_1, 1) /= 2) call abort
+if (ishftc (3_1, 1) /= 6) call abort
+if (ishftc (-1_1, 1) /= -1) call abort
+if (ishftc (-1_1, -1) /= -1) call abort
+if (ishftc (ishftc (96_1, 2), -2) /= 96) call abort
+
+if (ishftc (1_2, 0) /= 1) call abort
+if (ishftc (1_2, 1) /= 2) call abort
+if (ishftc (3_2, 1) /= 6) call abort
+if (ishftc (-1_2, 1) /= -1) call abort
+if (ishftc (-1_2, -1) /= -1) call abort
+if (ishftc (ishftc (25000_2, 2), -2) /= 25000) call abort
+
+if (ishftc (1_4, 0) /= 1) call abort
+if (ishftc (1_4, 1) /= 2) call abort
+if (ishftc (3_4, 1) /= 6) call abort
+if (ishftc (-1_4, 1) /= -1) call abort
+if (ishftc (-1_4, -1) /= -1) call abort
+if (ishftc (ishftc (1325876_4, 2), -2) /= 1325876) call abort
+end