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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@88609 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3147b28..d52914f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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.

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2dffff8..0ac9d61 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/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;
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2896509..99ba040 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/ishft.f90 b/gcc/testsuite/gfortran.dg/ishft.f90
new file mode 100644 (file)
index 0000000..f375556
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ishft.f90
@@ -0,0 +1,44 @@
+! { 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