diff options
Diffstat (limited to 'gcc/fortran/simplify.c')
| -rw-r--r-- | gcc/fortran/simplify.c | 122 |
1 files changed, 84 insertions, 38 deletions
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 2dffff845d9..253f68677a1 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -138,13 +138,44 @@ 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 * gfc_simplify_abs (gfc_expr * e) { gfc_expr *result; - mpfr_t a, b; if (e->expr_type != EXPR_CONSTANT) return NULL; @@ -171,17 +202,9 @@ gfc_simplify_abs (gfc_expr * e) result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); gfc_set_model_kind (e->ts.kind); - mpfr_init (a); - mpfr_init (b); - /* FIXME: Possible numerical problems. */ - mpfr_mul (a, e->value.complex.r, e->value.complex.r, GFC_RND_MODE); - mpfr_mul (b, e->value.complex.i, e->value.complex.i, GFC_RND_MODE); - mpfr_add (a, a, b, GFC_RND_MODE); - mpfr_sqrt (result->value.real, a, GFC_RND_MODE); - - mpfr_clear (a); - mpfr_clear (b); + mpfr_hypot (result->value.real, e->value.complex.r, + e->value.complex.i, GFC_RND_MODE); result = range_check (result, "CABS"); break; @@ -1557,8 +1580,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 +1608,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 +1615,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); + + 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); - return range_check (result, "ISHFT"); + gfc_free (bits); + return result; } @@ -1651,6 +1699,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 +1712,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 +1726,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 +1736,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 +1744,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; } |