+2007-01-09 Brooks Moses <brooks.moses@codesourcery.com>
+
+ 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 <pault@gcc.gnu.org>
PR fortran/30408
}
-/* 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
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");
}
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;
}
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");
}
}
}
- twos_complement (result->value.integer, isize);
+ convert_mpz_to_signed (result->value.integer, isize);
gfc_free (bits);
return result;
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)
}
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)
{
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);
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);
}
}
- twos_complement (result->value.integer, isize);
+ convert_mpz_to_signed (result->value.integer, isize);
gfc_free (bits);
return result;
gfc_simplify_not (gfc_expr * e)
{
gfc_expr *result;
- int i;
- mpz_t mask;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
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");
}
+2007-01-09 Brooks Moses <brooks.moses@codesourcery.com>
+
+ * 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 <brooks.moses@codesourcery.com>
* gfortran.dg/altreturn_2.f90: Removed executable bit.
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
+++ /dev/null
-! { 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) 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 (ishft (1_8, 0) /= 1) call abort
-if (ishft (1_8, 1) /= 2) call abort
-if (ishft (3_8, 1) /= 6) call abort
-if (ishft (-1_8, 1) /= -2) call abort
-if (ishft (-1_8, -60) /= z'F') 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
-
-if (ishftc (1_8, 0) /= 1) call abort
-if (ishftc (1_8, 1) /= 2) call abort
-if (ishftc (3_8, 1) /= 6) call abort
-if (ishftc (-1_8, 1) /= -1) call abort
-if (ishftc (-1_8, -1) /= -1) call abort
-if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) call abort
-end
-
-
--- /dev/null
+! { 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) 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 (ishft (1_8, 0) /= 1) call abort
+if (ishft (1_8, 1) /= 2) call abort
+if (ishft (3_8, 1) /= 6) call abort
+if (ishft (-1_8, 1) /= -2) call abort
+if (ishft (-1_8, -60) /= z'F') 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
+
+if (ishftc (1_8, 0) /= 1) call abort
+if (ishftc (1_8, 1) /= 2) call abort
+if (ishftc (3_8, 1) /= 6) call abort
+if (ishftc (-1_8, 1) /= -1) call abort
+if (ishftc (-1_8, -1) /= -1) call abort
+if (ishftc (ishftc (1325876_8, 2), -2) /= 1325876) call abort
+end
+
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff