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