mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-10 21:41:14 +08:00
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
This commit is contained in:
Tobias Schlüter
Tobias Schlüter
parent
d13256a357
commit
5d24a9774e
@ -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.
|
||||
|
||||
@ -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);
|
||||
else
|
||||
mpz_set_si (result->value.integer, e_int >> ashift);
|
||||
{
|
||||
for (i = 0; i < shift; i++)
|
||||
mpz_clrbit (result->value.integer, i);
|
||||
|
||||
return range_check (result, "ISHFT");
|
||||
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
|
||||
{
|
||||
for (i = isize - 1; i >= isize - ashift; i--)
|
||||
mpz_clrbit (result->value.integer, i);
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
44
gcc/testsuite/gfortran.dg/ishft.f90
Normal file
44
gcc/testsuite/gfortran.dg/ishft.f90
Normal file
@ -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
|
||||
Loading…
x
Reference in New Issue
Block a user