From f1dcb9bf3b6a96a117836e6787fa4d49c87ad995 Mon Sep 17 00:00:00 2001 From: Brooks Moses Date: Wed, 10 Jan 2007 05:46:13 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 18 +++ gcc/fortran/simplify.c | 136 ++++++++++++------ gcc/testsuite/ChangeLog | 9 ++ gcc/testsuite/gfortran.dg/chkbits.f90 | 23 +-- .../gfortran.dg/{ishft.f90 => ishft_1.f90} | 0 gcc/testsuite/gfortran.dg/ishft_2.f90 | 6 + gcc/testsuite/gfortran.dg/ishft_3.f90 | 11 ++ 7 files changed, 149 insertions(+), 54 deletions(-) rename gcc/testsuite/gfortran.dg/{ishft.f90 => ishft_1.f90} (100%) create mode 100644 gcc/testsuite/gfortran.dg/ishft_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/ishft_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5ea277ed0ea..8cf0bc3ebdf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2007-01-09 Brooks Moses + + 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 PR fortran/30408 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8ecabf03793..82005f1d58f 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 0a6ffa2e5ee..71488e554a2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2007-01-09 Brooks Moses + + * 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 * gfortran.dg/altreturn_2.f90: Removed executable bit. diff --git a/gcc/testsuite/gfortran.dg/chkbits.f90 b/gcc/testsuite/gfortran.dg/chkbits.f90 index 19ab5c722c6..4652439fddd 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 similarity index 100% rename from gcc/testsuite/gfortran.dg/ishft.f90 rename to 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 00000000000..96acf0e3b9b --- /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 00000000000..fa3938ef9f0 --- /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