aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog6
-rw-r--r--gcc/fortran/simplify.c109
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/ishft.f9044
4 files changed, 137 insertions, 27 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3147b28..d52914f 100644
--- 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
--- 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
--- 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
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
generated by cgit v1.1 at 2025-05-31 10:29:23 +0000